{Zlepsit autodetekci PS %!}

{$i-,g+,r-,s-}
{$ifndef modif}{$i modif.inc}{$endif}
{$define ilasm}
unit Pictures;
interface
uses chanels,formater,toolsb,
     {$ifdef windows}
     Windos,dos,{$ifdef graph}WinGraph;{$else}WinCrtx;{$endif}
     {$else}
       {$ifdef graph}Graph,{$endif}
       {$ifdef fgraph}fGraph,{$endif}
       Dos,{$ifdef crtx}crtx;{$else}crt;{$endif}  {Crt should be removed from here}
     {$endif}

{$ifdef fgraph}{$define Graph}{$endif}
{$ifdef windows}
 type pathstr=string;
 {$undef Graph}
{$endif}

	{There is a limited number of selectors in 16bit protected mode,
	 try to group more allocations together.}
{$ifdef windows} {$define StackAllocations} {$endif}
{$ifdef DPMI} {$define StackAllocations} {$endif}


type RGB=record
	red,Green,Blue:Byte;
	end;
     RGBWord=record
	red,Green,Blue:Word;
	end;
     Tpalette=record
	colors:Word;
	pal:array[0 .. 255] of RGB;
	end;
     Ppalette=^Tpalette;

     PAbstractLineProc=^AbstractLineProc;
     AbstractLineProc=object
	recurses:byte;
	pases:word;
	ActualPass:word;
	Description:Pchar;
	constructor Init;
	Procedure InitPassing(Count:Word;Name:Pchar); virtual;
	Function NextLine:integer;	virtual;
	end;
     PercentLineProc=object(AbstractLineProc)
	x,y:Byte;
	Procedure InitPassing(Count:Word;Name:Pchar); virtual;
	Function NextLine:integer;	virtual;
	end;


     PAbstractPicture=^AbstractPicture;
     AbstractPicture=object
	typ:char;		{A-abstraktni, B-bitmapovy, V-vektorovy, R-real}
	x,y:word;	        {it should not be negative}
	planes:byte;
	filename:^pathstr;
	palette:Ppalette;
	function Valid:Boolean; virtual;
	procedure Load(ext:ExtStr;AlineProc:PAbstractLineProc); virtual;
	Function Save(AlineProc:PAbstractLineProc):Boolean; virtual;
	Procedure FormR(i:integer;FData:Pointer); virtual;
	procedure LockData; virtual;
	Procedure UnlockData; virtual;
{$ifdef graph}procedure View(AlineProc:PAbstractLineProc); virtual;{$endif}
	end;

     LinePict=record
	      case byte of 0:(b:array[0..65528] of byte;);
			   1:(w:array[0..32764] of word;);
			   2:(d:array[0..8190] of real;);
	      end;
     ukLinePict=^LinePict;
     lines=array[0..16370] of ukLinePict;


     picture=object(AbstractPicture)
	data:^lines;
	Function Valid:Boolean; virtual;
	procedure Load(ext:ExtStr;AlineProc:PAbstractLineProc); virtual;
	Function Save(AlineProc:PAbstractLineProc):Boolean; virtual;
	Procedure FormR(i:integer;FData:Pointer); virtual;
	Procedure RfrmB(i:integer;NewData:Pointer);
	procedure Create(SizeX,SizeY:Word;pln:Word); virtual;
	procedure Create_(SizeX,SizeY:Word;pln:Word;SameP:PAbstractPicture); virtual;
	procedure Erase; virtual;
	Constructor Init;
	Destructor Done; virtual;
{$ifdef graph}procedure View(AlineProc:PAbstractLineProc); virtual;{$endif}
	end;

{     LargeArray=object
	Constructor Init;
	Destructor Done;
	Function MemberPtr(n:word):^longint;
	Procedure Set(n:word,x:longint);
	Function Get(n:word):longint);
	end;}


     PHistogram=^THistogram;
     THistogram=Array[0..255]of Longint;

     func2 = Procedure(P1,P2:Pointer;MaxX:Word;ukParameters:pointer);
     func1 = Procedure(P1:Pointer;MaxX:Word;ukParameters:Pointer);
     Binarfunc2 = Procedure(maxX:word;p1,p2:pointer);



     Point=record
       x,y:integer;
       end;

     myptr=record
     case byte of 0:(ofs,seg:Word);
		  1:(ptr:Pointer;);
		  2:(ptrB:^Byte);
		  3:(ptrW:^Word);
		  4:(ptrL:^Longint);
	 end;

     UkVectorObject=^VectorObject;
     VectorObject=record
	points:word;
	color:Byte;
	data:array[0..0] of point;
	end;
     AVectorObject=array[0..0]of UkVectorObject;

     VectorPicture=object(AbstractPicture)
	lines:Word;
	v:^AVectorObject;

	Function Valid:Boolean; virtual;
	Procedure Load(ext:extStr;AlineProc:PAbstractLineProc); virtual;
	Function Save(AlineProc:PAbstractLineProc):Boolean; virtual;
	Procedure FormR(i:integer;FData:Pointer); virtual;
	Procedure Erase;
	constructor Init;
	destructor Done;
{$ifdef graph}procedure View(AlineProc:PAbstractLineProc); virtual;{$endif}
	end;

     PCVOpt=^CVOpt;
     CVOpt=object
	pl,pa:Word;
	tisk:Boolean;
	AutoErase:Boolean;
	eps:Real;

	Constructor init(planes:Word);
	end;

type radek=array[0..$1FFF]of Longint;
     pradek=^radek;
     radekW=array[0..$1FFF]of Word;
     pradekW=^radekW;

     TElement=record
	 case byte of 1:(W:Longint);
		      2:(Fg,Bk:Word);
	 end;
      SElement=record
	items:Byte;
	E:array[0..11] of Telement;
	end;



Procedure AssignPicture(var p:AbstractPicture;const name:pathStr);
Procedure LoadPicture(var p:AbstractPicture;const s:PathStr;AlineProc:PAbstractLineProc);
Function SavePicture(var p:AbstractPicture;const s:PathStr;AlineProc:PAbstractLineProc):Boolean;
Procedure MovePicture(var srP,destP:picture;AlineProc:PAbstractLineProc);
Procedure Convert(var srP:Picture;var destP:picture;DestPlanes:byte;DestTyp:char;scale:Boolean;
		  AlineProc:PAbstractLineProc);
Procedure Separate(var srP:Picture;var destP:picture;color:char;AlineProc:PAbstractLineProc);

Procedure view(var p:abstractPicture);

Function pixel(var p:picture;x,y:integer):longint;
Function PixelPtr(var p:picture;x,y:integer):pointer;
Procedure SetPixel(var p:picture;x,y:integer;n:Longint);
Procedure ClearPixel(var p:picture;x,y:integer);
Function Compare(var obr1,obr2:picture;AlineProc:PAbstractLineProc):longint;
Procedure Mask(var Obr1:Picture;var Obr2:Picture;n:Word;AlineProc:PAbstractLineProc);
Procedure Median(var Obr1,Obr2:Picture;n:Byte;AlineProc:PAbstractLineProc);
Procedure Gauss(var Obr1,Obr2:Picture;n:Byte;AlineProc:PAbstractLineProc);
Procedure GaussDif(var Obr1,Obr2:picture;n:Byte;typ:char;AlineProc:PAbstractLineProc);
Procedure Crop(var Obr1:AbstractPicture;var Obr2:Picture;x0,y0,x1,y1:word;AlineProc:PAbstractLineProc);
Procedure Brush(var MainObr:Picture;var Stamp:AbstractPicture;Xpos,Ypos:word;AlineProc:PAbstractLineProc);
Procedure Canny(var im_in,im_out:picture;GausN:integer;scale:Real;AlineProc:PAbstractLineProc);
Procedure Flip(typ:char;var Obr:picture;AlineProc:PAbstractLineProc);
Procedure Rotate(degrees:integer;var Obr:picture;AlineProc:PAbstractLineProc);
Procedure Invert(var Obr:picture;AlineProc:PAbstractLineProc);
Procedure Histogram(var p:picture;var H:Phistogram);
Procedure Equalise(var EqObr:Picture;PercentLoss:byte);

Procedure Thr(var Obr:AbstractPicture;var ph:picture;h:integer;AlineProc:PAbstractLineProc);
Procedure Floyd(var Obr:AbstractPicture;var ph:Picture;h:integer;AlineProc:PAbstractLineProc);
Procedure PeelPlane(var obr:Picture;var PlaneX:Picture;PlaneNum:Byte);
Procedure JoinPlane(var PlaneX:Picture;var obr:Picture;PlaneNum:Byte);
Procedure Dilatation(var Obr,ObrD:Picture;typ:Word;AlineProc:PAbstractLineProc);
Procedure Erosion(var Obr,ObrD:Picture;typ:Word;AlineProc:PAbstractLineProc);
Procedure HitOrMiss(var Obr,ObrD:Picture;El:Telement;AlineProc:PAbstractLineProc);
Procedure Thin1Step(var Obr,ObrZ:Picture;El:Telement);
Procedure SeqThin(var Obr,ObrZ:Picture;El:Selement);


Procedure FormR(var p:AbstractPicture;i:Word;Data:Pointer);
Procedure RfrmB(var p:picture;i:word;NewData:Pointer);
Procedure Invert_L(P1:Pointer;MaxX:Word;Dummy:pointer);    {R=-R}
Procedure ReTabB(P1:Pointer;MaxX:Word;TabPtr:pointer); 	 {R:=Tab[R]}
Procedure ShLW(maxX:Word;ukradek:PRadek;dummy:pointer);
Procedure ShRW(maxX:Word;ukradek:PRadek;dummy:pointer);

Procedure SubbS(P1,P2:Pointer;MaxX:Word;Dummy:pointer);	 {R1:=R2-R1 scaled}
Procedure Add(P1,P2:Pointer;MaxX:Word;Dummy:pointer); 	 {R1:=R2+R1}
Procedure MaxW(maxX:Word;ukradek:PRadek;ukradekW:PRadekW);{R1:=max(R1,R2)}
Procedure MinW(maxX:Word;ukradek:PRadek;ukradekW:PRadekW);{R1:=min(R1,R2)}
Procedure Operation1(var Obr:Picture;Operation:func1;ukParameters:Pointer;AlineProc:PAbstractLineProc);
Procedure Operation2(var obr1,obr2:picture;Operation:func2;Param:Pointer;AlineProc:PAbstractLineProc);
Procedure XorR(maxX:Word;R1,R2:Pointer);	{R1:=R1 xor R2}
Procedure OrR(maxX:Word;R1,R2:Pointer); 	{R1:=R1 or R2}
Procedure AndR(maxX:Word;R1,R2:Pointer); 	{R1:=R1 and R2}
Procedure BinarOperation2(var Obr1,Obr2:Picture;Operation:BinarFunc2;AlineProc:PAbstractLineProc);

Procedure DeClasification(var Obr1:AbstractPicture;var Obr2:Picture;AlineProc:PAbstractLineProc);
Procedure MakeNodes(var Obr1,Obr2:Picture;AlineProc:PAbstractLineProc);
Procedure Convert2vector(var obr:picture;var vobr:VectorPicture;Options:PCVOpt;AlineProc:PAbstractLineProc);
Procedure AddVecLine(var v:VectorPicture;BytesInLine:Word);
Procedure CreatePalette(var ppal:Ppalette;planes:Byte);
Procedure ErasePalette(var ppal:Ppalette);
Procedure ReMapPalAsGray(var obr:picture);
Function GrayPalette(var p:AbstractPicture):Boolean; {Is this Gray scale palette?}
Function InvalidPalette(var ppal:Ppalette):Boolean; {Is this Gray scale palette?}
Procedure SortPal(pal:PPalette;var qoc:array of byte);
Function NearAvailPln(n:Word):Word;

Function WriteLineProc(l:integer;var p:picture):Byte;

Procedure Shr_R(maxX:Word;R:Pointer);             {R1:=R1 shr 1}
Procedure Shl_R(maxX:Word;R:Pointer;zbytek:Byte); {R1:=R1 shl 1}
Procedure NotR(maxX:Word;R:Pointer);		  {R1:=not(R1)}

Procedure Peel1plane(var p:picture;y:word;plane:byte;ukbity:pointer);
Procedure Join1plane(var p:picture;y:word;plane:byte;ukbity:pointer);
Procedure Separate_R(MaxX:Word;n:word;Idata:pointer;Odata:pointer);
Procedure JoinB(MaxX:Word;PtrBuf,ukbyte:pointer; inc:Word);

Procedure RGB_BGR(MaxX:Word;data:pointer);
procedure GausFunc(var obr:Picture;FuncC,GausN:byte;Mult,Offs:longint;AlineProc:PAbstractLineProc);
const	PicturesVer = $246;	{ v 2.46 }

	gfGaus     =0;
	gfGausDiffX=1;
	gfGausDiffY=2;
	gfGausdiff =3;
	gfCanny    =4;
	gfCannyFast=5;
	gfGausLap  =6;

        NoFill= $100;	{zakaz vyplnovani 0 pri Create}

type Color=record
	Red,Green,Blue:Byte;
	end;

     MATHeader=record
	identific:array [0..124] of char;
	idx:array [0..2] of char;
	unknown0:longint;
	ObjectSize:longint;
	unknown1:longint;
	unknown2:longint;

	StructureFlag:longint;
	unknown3:longint;
	unknown4:longint;
	DimFlag:longint;

	SizeX:longint;
	SizeY:longint;
	Flag1:	 Word;
	NameFlag:Word;
	end;


     OkoHeader=record
	identific:array [1..80] of char;
	ver:	word;
	modif:	word;
	Histogram:Word;
	Text:	Word;
	rows:	Word;
	cols:	Word;
	levels:	Word;
	identif:Byte;
	nic:array[0..416] of byte;
	end;

     RasHeader = record
       Name        : array[1..20] of char;
       Rows        : integer;
       Cols        : integer;
       TypSou      : integer; { 0-binarni, 1-8 bitu,2-8 bitu+PAL,3-4 bity,
				4-4 bity+PAL, 5-24 bite,6-16 bite,7- 32 bite}
       Zoom        : longint;
       Verze       : integer;
       Komprese    : integer; {0 - nekomprimovano}
			 {od Verze 1}
       Stav        : integer;
       xRasMin     : double;
       yRasMin     : double;
       xRasMax     : double;
       yRasMax     : double;
       Scale       : double;
			 {od Verze 2}
       TileWidth      : word; {- sirka tilu v pixelech}
       TileHeight     : word; {- vyska tilu v pixelech}
       TileOffsets    : longint; { - offset na pole longintu, ktere jsou adresami tilu v rastru (adresy se pocitaji od 0)}
       TileByteCounts : longint; { - offset na pole wordu, ktere obsahuji pocet bytu ulozenych v
				v jednotlivych tilech velikost tilu se muze lisit v zavislosti
				na hodnote TileCompression}
       TileCompression: byte;     {0 - nekomprimovano, 1 - varianta TIFF Packbits, 2 - CCITT G3}

       Dummy       : array[1..423] of byte;
     end;

   SUNRASHeader=record
	ras_magic:longint;
	ras_width:longint;
	ras_height:longint;
	ras_depth:longint;
	ras_length:longint;
	ras_type:longint;
	ras_maptype:longint;
	ras_maplength:longint;
	end;

   type TGAHeader=record
	IdentifLen:	Byte;
	ColorMapType:	Byte;
	ImageCodeType:	Byte;

	CMapOrigin:	Word;
	CMapLength:	Word;
	CMapEntrySize:	Byte;

	XOrigin:	Word;
	YOrigin:	Word;
	width:		Word;
	height:		Word;
	ImagePixSize:	Byte;
	ImageDescByte:	Byte;
	end;


   TIFHeader=record
	CharId:packed array[0..1] of Char;
	CharV:word;
	Pos:LongInt;
	end;
   TIFDirectory=record
	Tag,Field:Word;
	Long2,Value:LongInt;
	end;


   PCXHeader=record
       Id0:       Byte;
       version :  Byte;
       encoding:  Byte;
       bitPerPix: Byte;
       x0,y0:     Word;
       x1,y1:     Word;
       horizontal:Word;
       vertical:  Word;
       ColorMap:  array[0..15] of Color;
       reserved:  Byte;
       NumPlanes: Byte;
       bytesPerLine:word;
       PaletteInfo:Word;
       user:array[0..57]of byte;
   end;

   BMPHeader=record
	bfType:	    array [0..1]of char;
	bfSize:     Longint;
	case integer of
	   1:(bfReserved1:Word;
	     bfReserved2:Word;
	     bfOffBits:  Longint;);
	   2:(NextBABlock: longint;);
       end;
   BMPInfo_Coreinfo=record
	case byte of	 {BITMAPINFOHEADER}
	 0:(biSize:	  Longint;
	    biWidth:      Longint;
	    biHeight:     Longint;
	    biPlanes:     Word;
	    biBitCount:   Word;
	    biCompression:Longint;
	    biSizeImage:  Longint;
	    biXPelsPerMeter:Longint;
	    biYPelsPerMeter:Longint;
	    biClrUsed:Longint;
	    biClrImportant:Longint;);
	 1:(bcSize:	  Longint;
	    bcWidth:      Word;
	    bcHeight:     Word;
	    bcPlanes:     Word;
	    bcBitCount:   Word;);
     end;

   CUTHeader=record	{Dr Hallo}
	width:   WORD;
	height:  Word;
	Reserved:Word;
       end;
   CUTPalHeader=record
	FileId:  array[0..1] of char;
	Version: 	Word;
	Size:	 	Word;
	FileType:	Byte;
	SubType:	Byte;
	BoardID: 	Word;
	GraphicsMode:	WORD;
	MaxIndex:  	Word;
	MaxRed:		Word;
	MaxGreen:	Word;
	MaxBlue:	Word;
	PaletteId: array[0..19] of char;
       end;


   RGBQuad=record
	rgbBlue:Byte;
	rgbGreen:byte;
	rgbRed:Byte;
	rgbReserved:Byte;
     end;

type IconHeader=record
	idReserved:Word;
	idType:Word;
	idCount:Word;
     end;
     IconDirectoryEntry=record
	bWidth:Byte;
	bHeight:Byte;
	bColorCount:Byte;
	bReserved:Byte;
	wPlanes:Word;
	wBitCount:Word;
	dwBytesInRes:Longint;
	dwImageOffset:Longint;
    end;


   type WPGHeader=record
	FileId:	     longint;
	DataOffset:  Longint;
	ProductType: Word;
	FileType:    Word;
	MajorVersion:Byte;
	MinorVersion:Byte;
	EncryptKey:  Word;
	Reserved:    Word;
       end;
     WPGRecord=record
	RecType:     byte;
	RecordLength:longint;
       end;
     WPG2Record=record
	RecClass:    byte;
	RecType:     byte;
	Extension:   longint;
	RecordLength:longint;
       end;
     WPG2BitmapType1=record
	Width:     word;
	Height:	   word;
	Depth:     byte;
	Compression:byte;
       end;
     _BitmapType1=record
	Width:     word;
	Height:	   word;
	Depth:     word;
	HorzRes:   word;
	VertRes:   word;
       end;
     _BitmapType2=record
	RotAngle:  word;
	LowLeftX:  word;
	LowLeftY:  word;
	UpRightX:  word;
	UpRightY:  word;
	Width:     word;
	Height:	   word;
	Depth:     word;
	HorzRes:   word;
	VertRes:   word;
       end;
     _ColorMapRec=record
	StartIndex:  word;
	NumOfEntries:word;
      end;
     WPG2Start=record
	HorizontalUnits: WORD;
	VerticalUnits: WORD;
	PosSizePrecision: BYTE;
       end;


   PaletteRAS=record
	Flag:Byte;
	Red,Green,Blue:Byte;
	end;
   Tmez=array[0..255] of byte;

{typy strukturnich elementu pro morfologii}
const ElLup=  4;   ElUp   =8;   ElRup  =16;
      ElLeft= 2;   ElCentr=1;   ElRight=32;
      ElLdown=256; ElDown =128; ElRdown=64;

      El8=ElLup+ElUp+ElRup+ElLeft+ElCentr+ElRight+ElLdown+ElDown+ElRdown;
      El4=ElUp+ElLeft+ElCentr+ElRight+ElDown;

const M8:SElement=(
	Items:8;
	E:((Fg:ElCentr+ElRUp+ElUp+ElLUp+ElLeft+                         +ElRight;
            Bk:        ElDown),
	   (Fg:ElCentr+ElRUp+ElUp+ElLUp+ElLeft+ElLDown;
            Bk:               ElRDown),
	   (Fg:ElCentr+      ElUp+ElLUp+ElLeft+ElLDown+ElDown;
            Bk:                       ElRight),
	   (Fg:ElCentr+		  ElLUp+ElLeft+ElLDown+ElDown+ElRDown;
            Bk:                               ElRUp),
	   (Fg:ElCentr+                 ElLeft+ElLDown+ElDown+ElRDown+ElRight;
            Bk:                                     ElUp),
	   (Fg:ElCentr+ElRUp+                  ElLDown+ElDown+ElRDown+ElRight;
            Bk:					         ElLUp),
	   (Fg:ElCentr+ElRUp+ElUp+                     ElDown+ElRDown+ElRight;
            Bk:         				       ElLeft),
	   (Fg:ElCentr+ElRUp+ElUp+ElLUp+                      ElRDown+ElRight;
            Bk:ElLDown),

	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));

      L8:SElement=(
	Items:8;
	E:((Fg:ElCentr+ElLDown+ElDown+ElRDown;
	    Bk:ElRUp+ElUp+ElLUp),
	   (Fg:ElCentr+        ElDown+ElRDown+ElRight;
	    Bk:       ElUp+ElLUp+ElLeft),
	   (Fg:ElCentr+               ElRDown+ElRight+ElRUp;
	    Bk:            ElLUp+ElLeft+ElLDown),
	   (Fg:ElCentr+                       ElRight+ElRUp+ElUp;
	    Bk:			 ElLeft+ElLDown+ElDown),
	   (Fg:ElCentr+                               ElRUp+ElUp+ElLUp;
	    Bk:                         ElLDown+ElDown+ElRDown),
	   (Fg:ElCentr+					    ElUp+ElLUp+ElLeft;
	    Bk:                                 ElDown+ElRDown+ElRight),
	   (Fg:ElCentr+ElLDown+					+ElLUp+ElLeft;
	    Bk:ElRUp+                                  ElRDown+ElRight),
	   (Fg:ElCentr+ElLDown+ElDown+				       ElLeft;
	    Bk:ElRUp+ElUp+                                     ElRight),

	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));

    D8:SElement=(
	Items:8;
	E:((Fg:ElCentr+        ElDown;
	    Bk:ElRUp+ElUp+ElLUp+ElLeft+                         +ElRight),
	   (Fg:ElCentr+               ElRDown;
	    Bk:ElRUp+ElUp+ElLUp+ElLeft+ElLDown),
	   (Fg:ElCentr+                       ElRight;
	    Bk:      ElUp+ElLUp+ElLeft+ElLDown+ElDown),
	   (Fg:ElCentr+                               ElRUp;
	    Bk:		  ElLUp+ElLeft+ElLDown+ElDown+ElRDown),
	   (Fg:ElCentr+                                     ElUp;
	    Bk:                 ElLeft+ElLDown+ElDown+ElRDown+ElRight),
	   (Fg:ElCentr+					         ElLUp;
	    Bk:ElRUp+                  ElLDown+ElDown+ElRDown+ElRight),
	   (Fg:ElCentr+         				       ElLeft;
	    Bk:ElRUp+ElUp+                     ElDown+ElRDown+ElRight),
	   (Fg:ElCentr+ElLDown;
	    Bk:ElRUp+ElUp+ElLUp+                      ElRDown+ElRight),

	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));

    E8:SElement=(
	Items:8;
	E:((Fg:ElCentr+        ElDown;
	    Bk:ElRUp+ElUp+ElLUp+ElLeft+                         +ElRight),
	   (Fg:ElCentr;
	    Bk:ElRUp+ElUp+ElLUp+ElLeft+ElLDown+ElDown           +ElRight),
	   (Fg:ElCentr+                       ElRight;
	    Bk:      ElUp+ElLUp+ElLeft+ElLDown+ElDown),
	   (Fg:ElCentr;
	    Bk:	     ElUp+ElLUp+ElLeft+ElLDown+ElDown+ElRDown+ElRight),
	   (Fg:ElCentr+                                     ElUp;
	    Bk:                 ElLeft+ElLDown+ElDown+ElRDown+ElRight),
	   (Fg:ElCentr;
	    Bk:ElRUp+ElUp+      ElLeft+ElLDown+ElDown+ElRDown+ElRight),
	   (Fg:ElCentr+         				       ElLeft;
	    Bk:ElRUp+ElUp+                     ElDown+ElRDown+ElRight),
	   (Fg:ElCentr;
	    Bk:ElRUp+ElUp+ElLUp+ElLeft+        ElDown+ElRDown+ElRight),

	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));


    I8:SElement=(
	Items:1;
	E:((Fg:ElCentr;
	    Bk:ElRUp+ElUp+ElLUp+ElLeft+ElLDown+ElDown+ElRDown+ElRight),

	   (Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));


    Q8:SElement=(
	Items:1;
	E:((Fg:ElCentr+ElRUp+ElUp+ElLUp+ElLeft+ElLDown+ElDown+ElRDown+ElRight;
	    Bk:0),

	   (Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));


    C8:SElement=(
	Items:8;
	E:((Fg:ElRUp+ElUp+ElLUp+ElLeft+                         +ElRight;
	    Bk:ElCentr),
	   (Fg:ElRUp+ElUp+ElLUp+ElLeft+ElLDown;
	    Bk:ElCentr),
	   (Fg:      ElUp+ElLUp+ElLeft+ElLDown+ElDown;
	    Bk:ElCentr),
	   (Fg:		  ElLUp+ElLeft+ElLDown+ElDown+ElRDown;
	    Bk:ElCentr),
	   (Fg:                 ElLeft+ElLDown+ElDown+ElRDown+ElRight;
	    Bk:ElCentr),
	   (Fg:ElRUp+                  ElLDown+ElDown+ElRDown+ElRight;
	    Bk:ElCentr),
	   (Fg:ElRUp+ElUp+                     ElDown+ElRDown+ElRight;
	    Bk:ElCentr),
	   (Fg:ElRUp+ElUp+ElLUp+                      ElRDown+ElRight;
	    Bk:ElCentr),

	   (Fg:0;Bk:0),(Fg:0;Bk:0),
	   (Fg:0;Bk:0),(Fg:0;Bk:0)));


const decode:array[0..7] of byte = (127,191,223,239,247,251,253,254);
      decodeI:array[0..7] of byte = (128,64,32,16,8,4,2,1);
      offsetY:integer=0;
      offsetX:integer=0;
      SetPalette:Boolean=True;
      EraseBadImage:Boolean=False;

      ErrAnother=127;
      ErrOK     =  0;
      ErrParm   = -1;   {nevhodna maska nebo neplatny parametr}
      ErrFormat = -2;   {nevhodny format obrazku}
      ErrRdDisk = -3;   {chyba pri praci s diskem}
      ErrWrDisk = -4;   {chyba pri praci s diskem}
      ErrMem    = -5;   {neni dost pameti}
      ErrBrk    = -6;   {zastaveno uzivatelem}
      ErrData   = -7;   {chyba v datech obrazku}
      ErrVariant= -8;   {nepodporovana varianta dat}

Function PeepError:integer;
Function ReadError:integer;
Procedure WriteError(Error:integer);
Function GetErrorString(Error:integer):String;


Function ReadInt(var txt:Text;var c:char):integer;

implementation {------------------------------------------------------------}
uses {$ifdef jpg}jpg_rw,{$endif}
     ftgr;



Constructor AbstractLineProc.init;
begin
 recurses:=1;
 Description:=nil;
 pases:=1;
end;

Procedure AbstractLineProc.initPassing(Count:Word;Name:Pchar);
begin
 pases:=count-1;
 actualPass:=0;
 Description:=Name;
end;


Function AbstractLineProc.NextLine:integer; assembler;
asm
{$ifdef Windows}
	call	KeyPressed
{$endif}
	XOR	AX,AX
end;


Procedure PercentLineProc.initPassing(Count:Word;Name:Pchar);
begin
 pases:=count-1;
 if pases<=0 then pases:=1;
 actualPass:=0;
 Description:=Name;
{write(Name,' ');{}
 x:=whereX;
 y:=whereY;
end;

Function PercentLineProc.NextLine:integer;
var i:longint;
begin
 inc(ActualPass);
{$ifdef  Windows}KeyPressed;{$endif}
 if ActualPass mod 8 <> 1 then exit;
 i:=(longint(100)*ActualPass)div Pases;
 gotoXY(x,y);
 write(i:3,'%');
{ if keypressed then halt(1);}
 NextLine:=0;
end;

Function WriteLineProc(l:integer;var p:picture):Byte;
var i:Word;
begin
{$ifdef graph}
 for i:=0 to p.y do putpixel(l,i,(pixel(p,l,i) shr 4));
 if keypressed then halt(1);
 WriteLineProc:=0;
 {$endif}
end;


Procedure PeelB(MaxX:Word;PtrW,ukbyte:pointer; inc:Word);  Assembler;
asm
	push	ds
	push	es

	mov	cx,MaxX
	mov	dx,inc

	les	di,ukbyte
	lds	si,ptrW

@lopx:  mov	al,byte ptr ds:[si]
	stosb
	add	si,dx
	loop	@lopx

	pop	es
	pop	ds
end;


Procedure PeelB2W(MaxX:Word;PtrW,ukWord:pointer; inc:Word);  Assembler;
asm
	push	ds
	push	es

	mov	cx,MaxX
	mov	dx,inc

	les	di,ukWord
	lds	si,ptrW

	mov	ah,0
@lopx:  mov	al,byte ptr ds:[si]
	stosw
	add	si,dx
	loop	@lopx

	pop	es
	pop	ds
end;

Procedure JoinB(MaxX:Word;PtrBuf,ukByte:pointer; inc:Word);  Assembler;
asm
	push	ds
	push	es

	mov	cx,MaxX
	mov	dx,inc

	les	di,PtrBuf
	lds	si,ukByte

@lopx:  lodsb
	mov	byte ptr es:[di],al
	add	di,dx
	loop	@lopx

	pop	es
	pop	ds
end;


Procedure JoinW2B(MaxX:Word;PtrBuf,ukWord:pointer; inc:Word);  Assembler;
asm
	push	ds
	push	es

	mov	cx,MaxX
	mov	dx,inc

	les	di,PtrBuf
	lds	si,ukWord

@lopx:  lodsw
	mov	byte ptr es:[di],al
	add	di,dx
	loop	@lopx

	pop	es
	pop	ds
end;




Procedure PeelX(MaxX:Word;PtrW,ukbity:pointer;element:Byte; inc:Word);  Assembler;
asm
	push	ds
	push	es

	mov	cx,MaxX
	mov	al,element
	mov	dx,inc

	mov	bl,128

	les	di,ukbity
	lds	si,ptrW

@lopx:  test	byte ptr ds:[si],al
	jz	@nic
	or      byte ptr es:[di],bl
@nic:   ror	bl,1
	jnc	@noinc
	inc     di

@noinc: add	si,dx		{inc}
	loop	@lopx

	pop	es
	pop	ds
end;


Procedure JoinX(MaxX:Word;PtrW,ukbity:pointer;element:Byte; inc:Word);  Assembler;
asm
	push	ds
	push	es

	mov	cx,MaxX
	mov	al,element
	mov	dx,inc

	mov	bl,128

	les	di,ukbity
	lds	si,ptrW

@lopx:  test	byte ptr es:[di],bl
	jz	@nic
	or      byte ptr ds:[si],al
@nic:   ror	bl,1
	jnc	@noinc
	inc     di

@noinc: add	si,dx	{inc}
	loop	@lopx

	pop	es
	pop	ds
end;



Procedure SubbS(P1,P2:Pointer;MaxX:Word;Dummy:Pointer); assembler;
asm
	PUSH	ES
	PUSH	DS
	CLD		{auto increment}
	MOV	CX,word ptr maxX
	LES	DI,P1
	LDS	SI,P2

@@Loop: LODSW
	add  ax,256
	sub  ax,Word Ptr ES:DI
	shr  ax,1
	STOSW
	LOOP	@@Loop

	POP	DS
	POP	ES
end;

Procedure Add(P1,P2:Pointer;MaxX:Word;Dummy:Pointer); assembler;
asm
	PUSH	ES
	PUSH	DS
	CLD		{auto increment}
	MOV	CX,word ptr maxX
	LES	DI,P1
	LDS	SI,P2

@@Loop: LODSW
	add  ax,Word Ptr ES:DI
	STOSW
	LOOP	@@Loop

	POP	DS
	POP	ES
end;

Procedure MaxW(maxX:Word;ukradek:PRadek;ukradekW:PRadekW);
var p1:MyPtr Absolute ukradek;
    p2:MyPtr Absolute ukradekW;
begin
while MaxX>0 do
	begin
	if p1.ptrW^<p2.ptrW^ then p1.ptrW^:=p2.ptrW^;
	inc(p1.ofs,2);
	inc(p2.ofs,2);
	dec(MaxX);
	end;
end;

Procedure MinW(maxX:Word;ukradek:PRadek;ukradekW:PRadekW);
var p1:MyPtr Absolute ukradek;
    p2:MyPtr Absolute ukradekW;
begin
while MaxX>0 do
	begin
	if p1.ptrW^>p2.ptrW^ then p1.ptrW^:=p2.ptrW^;
	inc(p1.ofs,2);
	inc(p2.ofs,2);
	dec(MaxX);
	end;
end;

Procedure ShLW(maxX:Word;ukradek:PRadek;dummy:pointer);
var p1:MyPtr Absolute ukradek;
    p2:MyPtr;
begin
dec(maxX);
p2:=p1;
inc(p2.ofs,2);
while MaxX>0 do
	begin
	p1.ptrW^:=p2.ptrW^;
	inc(p1.ofs,2);
	inc(p2.ofs,2);
	dec(MaxX);
	end;
end;

Procedure ShRW(maxX:Word;ukradek:PRadek;dummy:pointer);
var p1:MyPtr Absolute ukradek;
    p2:MyPtr;
begin
dec(maxX);
inc(p1.ofs,2*MaxX);
p2:=p1;
dec(p2.ofs,2);
while MaxX>0 do
	begin
	p1.ptrW^:=p2.ptrW^;
	dec(p1.ofs,2);
	dec(p2.ofs,2);
	dec(MaxX);
	end;
end;


Procedure picture.FormR(i:integer;FData:Pointer);
var j:Word;
    ConvStruct:BasicFormStruct;
    sxi:Byte;
begin
if data=nil then exit;
if i>=y then i:=y-1;
if i<0 then i:=0;

 ConvStruct.Items:=X;
 ConvStruct.SrcTyp:=Typ;
 if Typ='P' then ConvStruct.SrcTyp:='G';
 ConvStruct.SrcPlanes:=planes;
 ConvStruct.DestTyp:='G';
 ConvStruct.DestPlanes:=16;
 ConvStruct.Options:=NoScale;

 if (typ='G')or(typ='B') then
	begin
	sxi:=pck(Planes,Typ);
	GrayProcTable[sxi,pck(16,'G')](@ConvStruct,data^[i],Fdata);
	exit;
	end;

 C_XX_YY(@ConvStruct,data^[i],Fdata);

end;


Procedure picture.RfrmB(i:integer;NewData:Pointer);
type poleW=array[0..32068] of word;
var ConvStruct:BasicFormStruct;
    sxi:Byte;

begin
if i>=y then i:=y-1;
if i<0 then i:=0;
if NewData=nil then exit;

 ConvStruct.Items:=X;
 ConvStruct.SrcTyp:='G';
 ConvStruct.SrcPlanes:=16;
 ConvStruct.DestTyp:=typ;
 if Typ='P' then ConvStruct.DestTyp:='G';
 ConvStruct.DestPlanes:=planes;
 ConvStruct.Options:=NoScale;

 if (typ='G')or(typ='B') then
	begin
	sxi:=pck(Planes,Typ);
	GrayProcTable[pck(16,'G'),sxi](@ConvStruct,NewData,data^[i]);
	exit;
	end;

 C_XX_YY(@ConvStruct,NewData,Data^[i]);
end;



Procedure Invert_L(P1:Pointer;MaxX:Word;Dummy:pointer); assembler;
asm
	PUSH	ES
	CLD		{auto increment}

	MOV	CX,word ptr maxX
	LES	DI,P1

@@Loop: mov	ax,Word Ptr ES:DI
	neg	ax
	STOSW
	LOOP	@@Loop

	POP	ES
end;

Procedure RGB_BGR(MaxX:Word;data:pointer);  assembler;
asm
	push	es

	les     di,data
	mov	si,di
	add	si,2

	mov	cx,MaxX
@loop:	mov	al,byte ptr es:[di]
	mov	ah,byte ptr es:[si]

	mov	byte ptr es:[di],ah
	mov	byte ptr es:[si],al

	add	di,3
	add	si,3
	loop	@loop

	pop	es
end;

Procedure Separate_R(MaxX:Word;n:word;Idata:pointer;Odata:pointer);  assembler;
asm
	push	es
	push	ds

	les     di,Odata
	lds     si,Idata

	add	si,n

	mov	cx,MaxX
	cld
@loop:	movsb
	add	si,2
	loop	@loop

	pop	ds
	pop	es
end;



Procedure ReTabB(P1:Pointer;MaxX:Word;TabPtr:pointer); assembler;	{R:=Tab[R]}
asm
	PUSH	ES
	PUSH	DS
	CLD		{auto increment}

	MOV	CX,word ptr maxX
	LES	DI,P1
	LDS	SI,TabPtr

	mov	bh,0
	mov	ah,0
@@Loop: mov	bl,byte Ptr ES:DI
	mov	al,byte ptr DS:[SI+BX]
	STOSW
	LOOP	@@Loop

	POP	DS
	POP	ES
end;

{$ifdef Graph}
Procedure ViewT(var p:picture); assembler;
asm
	call	GetMaxY
	les	si,p
	mov	dx,es:[si].picture.y
	cmp	ax,dx
	jge	@@loopx
	mov	dx,ax

@@loopx:les	si,p
	mov	cx,es:[si].picture.x
	dec	cx
@@loopy:push	cx
	push	dx

	les	si,p
	push	es
	push	si
	push    cx
	push	dx
	call    pixel
	or	al,al
	jz	@@nebod

	pop	dx
	pop	cx
	push	cx
	push	dx

	push	cx
	push	dx
	mov	ax,Green
	push	ax
	call    PutPixel

@@nebod:pop	dx
	pop	cx
	loop	@@loopy
	dec	dx
	jnz	@@loopx
end;

{$endif}

Function PixelPtr(var p:picture;x,y:integer):pointer;		assembler;
label KONEC,binarni;		{nemeni SI !!!}
asm
	push	es
	les	di,p

	cmp	x,0		{kontrola souradnic x a y}
	jge	@@nclx
	mov	x,0
@@nclx: cmp	y,0
	jge	@@ncly
	mov	y,0
@@ncly: mov	ax,ES:DI.picture.y
	cmp     ax,y
	jg	@@ncgy
	dec	ax
	mov	y,ax
@@ncgy:	mov	ax,ES:DI.picture.x
	cmp     ax,x
	jg	@@ncgx
	dec	ax
	mov	x,ax

@@ncgx: mov	cl,ES:DI.picture.planes
	mov	dx,0
	mov	ax,0
{---------------------}
	cmp	cl,16
	jne	@nePl16


	les	di,ES:DI.picture.data  	{wordovy obrazek 16 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	mov	ax,ES:[DI+BX]
	add	ax,x
	add	ax,x
	mov	dx,ES:[DI+BX+2]
	jmp	KONEC

{---------------------}
@nePL16:cmp	cl,8
	jne	@nePl8

	les	di,ES:DI.picture.data  	{bytovy obrazek 8 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	mov	ax,ES:[DI+BX]
	add	ax,x
	mov	dx,ES:[DI+BX+2]
	jmp	KONEC

{---------------------}
@nePL8: cmp	cl,32
	jne	@nePl32

	les	di,ES:DI.picture.data  	{dwordovy obrazek 32 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	mov	ax,ES:[DI+BX]
	add	ax,x
	add	ax,x
	add	ax,x
	add	ax,x
	mov	dx,ES:[DI+BX+2]
	jmp	KONEC

{---------------------}
@nePL32:
	mov	DX,0
	mov	AX,0

KONEC:	pop	es		{vystup:DX:AX}
end;

Function pixel(var p:picture;x,y:integer):longint;		assembler;
label KONEC,binarni;		{nemeni SI !!!}
asm
	push	es
	les	di,p

	cmp	x,0		{kontrola souradnic x a y}
	jge	@@nclx
	mov	x,0
@@nclx: cmp	y,0
	jge	@@ncly
	mov	y,0
@@ncly: mov	ax,ES:DI.picture.y
	cmp     ax,y
	jg	@@ncgy
	dec	ax
	mov	y,ax
@@ncgy:	mov	ax,ES:DI.picture.x
	cmp     ax,x
	jg	@@ncgx
	dec	ax
	mov	x,ax

{---------------------}
@@ncgx:	mov	cl,ES:DI.picture.planes
	mov	dx,0			{Output Hi word value}

	cmp	cl,32
	jne	@nePl32

	les	di,ES:DI.picture.data  	{dwordovy obrazek 32 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	add	di,x
	add	di,x
	add	di,x
	mov	ax,word ptr ES:DI
	add	di,2
	mov	dx,word ptr ES:DI
	jmp	KONEC

{---------------------}

@nePl32:cmp	cl,24
	jne	@nePl24

	les	di,ES:DI.picture.data  	{3 bytovy obrazek 24 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	add	di,x
	add	di,x
	mov	ax,word ptr ES:DI
	mov	dl,byte ptr ES:[DI+2]
	jmp	KONEC

{---------------------}
@nePl24:cmp	cl,16
	jne	@nePl16

	les	di,ES:DI.picture.data  	{wordovy obrazek 16 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	add	di,x
	mov	ax,word ptr ES:DI
	jmp	KONEC

{---------------------}
@nePL16:cmp	cl,8
	jne	@nePl8

	les	di,ES:DI.picture.data  	{bytovy obrazek 8 vrstev}
	mov	bx,y		{ pixel:=p.data^[y]^[x];}
	shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	mov	ah,0
	mov	al,byte ptr ES:DI
	jmp	KONEC

{---------------------}
@nePL8: cmp	cl,4
	jne	@nePl4

	les	di,ES:DI.picture.data  	{pulbytovy obrazek 4 vrstvy}
	mov	bx,y
	shl	bx,2
	les	di,ES:[DI+BX]
	mov	ax,x
	shr	ax,1
	jnc	@Horni4
	add	di,ax
	mov	ah,0
	mov	al,byte ptr ES:DI
	and	al,0Fh
	jmp	KONEC

@Horni4:add	di,ax
        mov	ah,0
	mov	al,byte ptr ES:DI
        shr	al,4
        jmp	KONEC

{---------------------}
@nePL4: cmp	cl,2
	jne	@nePl2

	les	di,ES:DI.picture.data  	{dvouurovnovy obrazek 2 vrstvy}
	mov	bx,y
	shl	bx,2
	les	di,ES:[DI+BX]
	mov	ax,x
	mov	cl,al
	shr	ax,2

	xor	cl,011b
	and	cl,011b
	shl	cl,1
	mov	ah,0
	mov	al,byte ptr ES:DI
	shr	al,cl
	and	al,011b
	jmp	KONEC


{---------------------}
@nePl2: cmp	cl,1
	jne	Konec

	les	di,ES:DI.picture.data	{binarni obrazek 1 vrstva}
        mov	bx,y
	shl	bx,2
	les	di,ES:[DI+BX]
	mov	ax,x
        mov	cl,al
        and	cl,0111b
	shr	ax,3
	add	di,ax
	mov	al,byte ptr ES:DI
        inc	cl
        shl	al,cl
	mov	ax,0
	adc	al,0

KONEC:	pop	es		{vystup:DX:AX}
end;

Procedure SetPixel(var p:picture;x,y:integer;n:Longint);
var b:byte;
begin
if x<0 then x:=0;
if y<0 then y:=0;
if x>=p.X then x:=p.x-1;
if y>=p.y then y:=p.y-1;
if p.data=nil then exit;

if p.planes=1 then
  asm
  	push	es
  	les	di,ES:DI.picture.data
        mov	bx,y
        shl	bx,2
	les	di,ES:[DI+BX]
	mov	ax,x
        mov	cl,al
        and	cl,0111b
	shr	ax,3
	add	di,ax
	mov	al,10000000b
        shr	al,cl
	cmp	word ptr n,0
        je	@set0
	or	byte ptr ES:DI,al
        jmp	@setOK
@set0:	xor	al,$FF
	and	byte ptr ES:DI,al
@setOK:	pop	es
  end;

if p.planes=2 then
  asm
	push	es
	les	di,p
	les	di,ES:DI.picture.data  	{dvouurovnovy obrazek 2 vrstvy}
	mov	bx,y
	shl	bx,2
	les	di,ES:[DI+BX]
	mov	ax,x
	mov	cl,al
	shr	ax,2
	add	di,ax

	mov	ah,011b

	xor	cl,011b
	and	cl,011b
	shl	cl,1
	mov	al,byte ptr n
	and     al,ah

	shl	al,cl
	shl	ah,cl
	xor	ah,0FFh
	and	byte ptr ES:[DI],ah
	or	byte ptr ES:[DI],al

	pop	es
  end;

if p.planes=4 then
  asm
        push	es
	les	di,p
	les	di,ES:DI.picture.data  	{ pixel:=p.data^[y]^[x];}
        mov	bx,y
        shl	bx,2
        les	di,ES:[DI+BX]
        mov	ax,x
        shr	ax,1
        jnc	@Horni4
        add	di,ax
        mov	al,byte ptr n
        and	byte ptr ES:DI,0F0h
	jmp	@uloz4

@Horni4:add	di,ax
	mov	al,byte ptr n
	and	byte ptr ES:DI,0Fh
	shl	al,4
@Uloz4:	or	byte ptr ES:DI,al
        pop	es
  end;
if p.planes=8 then
  asm
        push	es
        les	di,p
	les	di,ES:DI.picture.data  	{ pixel:=p.data^[y]^[x];}
        mov	bx,y
        shl	bx,2
        les	di,ES:[DI+BX]
        add	di,x
        mov	al,byte ptr n
	mov	byte ptr ES:DI,al
	pop	es
        end;
if p.planes=16 then
  asm
        push	es
	les	di,p
	les	di,ES:DI.picture.data  	{ pixel:=p.data^[y]^[x];}
        mov	bx,y
        shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	add	di,x
	mov	ax,word ptr n
	mov	word ptr ES:DI,ax
	pop	es
  end;
if p.planes=24 then
  asm
	push	es
	les	di,p
	les	di,ES:DI.picture.data  	{ pixel:=p.data^[y]^[x];}
	mov	bx,y
	shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	add	di,x
	add	di,x

	mov	ax,word ptr n
	mov	dx,word ptr n+2
	mov	word ptr ES:DI,ax
	mov	byte ptr ES:DI+2,dl
	pop	es
  end;

if p.planes=32 then
  asm
	push	es
	les	di,p
	les	di,ES:DI.picture.data  	{ pixel:=p.data^[y]^[x];}
	mov	bx,y
	shl	bx,2
	les	di,ES:[DI+BX]
	add	di,x
	add	di,x
	add	di,x
	add	di,x

	mov	ax,word ptr n
	mov	dx,word ptr n+2
	mov	word ptr ES:DI,ax
	mov	word ptr ES:DI+2,dx
	pop	es
  end;

end;

{---------End of assembler procedures---------}
(*
Function DefaultLineProc(l:integer;var p:AbstractPicture):Byte;
begin
{$ifdef Windows}
  KeyPressed;
{$endif}
  DefaultLineProc:=0;
end;
*)
{---------End of Pascal duplications of assembler procedures---------}


Procedure RfrmB(var p:picture;i:word;NewData:Pointer);
begin
 p.rfrmb(i,NewData);
end;


{precte integer ze souboru na stejne radce a vrati znak za nim}
Function ReadInt(var txt:Text;var c:char):integer;
var i:integer;
    sign:Boolean;
label 10;			
begin
I:=0;
sign:=False;
while (c < '0') or (c > '9') do       { dojede na pocatek cisla }
	begin
	if eof(txt) then goto 10;
	Read(txt,c);
	c:=UpCase(c);
	if c in [#0,#10,#13,';',#128..#255] then goto 10;
	if c='-' then Sign:=True;
	end;
repeat		          { tady nactu cislo }
 i:=10*i + ord(c)-ord('0');
 Read(txt,c);
until not((c >= '0') and (c <= '9'));
10:
if Sign then i:=-i;
ReadInt:=I;
end;


{-------------Metody abstraktni tridy pictures----------}
{$ifdef Graph}
Procedure AbstractPicture.View;
begin
 ClearViewPort;
end;
{$endif}

Function AbstractPicture.Valid:Boolean;
begin
 Valid:=True;
end;

Procedure AbstractPicture.Load;
begin
end;

Function AbstractPicture.Save(AlineProc:PAbstractLineProc):Boolean;
begin
 Save:=False;
end;

Procedure AbstractPicture.FormR(i:integer;FData:Pointer);
begin
end;

Procedure AbstractPicture.LockData;
begin
end;

Procedure AbstractPicture.UnLockData;
begin
end;

Procedure ErasePalette(var ppal:Ppalette);
begin
 if ppal=nil then exit;
 freemem(ppal,ppal^.Colors*Sizeof(RGB)+sizeof(Word));
 ppal:=nil;
end;

Procedure CreatePalette(var ppal:Ppalette;planes:Byte);{output is Gray scale palette}
var i,j:Word;
    Colors:Word;
begin
 ErasePalette(ppal);
 if (planes>8)or(planes=0) then exit;

 Colors:=1 shl planes;
 getmem(ppal,Colors*Sizeof(RGB)+sizeof(Word));
 ppal^.Colors:=Colors;
 for i:=0 to Colors-1 do
	begin
	j:=i*255 div (Colors-1);
	ppal^.pal[i].Red  := j;
	ppal^.pal[i].Green:= j;
	ppal^.pal[i].Blue := j;
	end;
end;

Function GrayPalette(var p:AbstractPicture):Boolean; {Is this Gray scale palette?}
var i,j:Word;
begin
 GrayPalette:=True;
 if (P.Palette=nil)or(not(p.valid)) then exit;
 GrayPalette:=False;
 for i:=0 to p.palette^.Colors-1 do
	begin
	j:=i*255 div (p.palette^.Colors-1);
	if ((p.palette^.pal[i].Red  <>j) or
	    (p.palette^.pal[i].Green<>j)) or
	    (p.palette^.pal[i].Blue <>j) then exit;
	end;
 GrayPalette:=True;
end;


Function InvalidPalette(var ppal:Ppalette):Boolean; {Is this Gray scale palette?}
var i:Word;
begin
 InvalidPalette:=True;
 if(ppal=nil) then exit;
 InvalidPalette:=False;
 for i:=0 to ppal^.Colors-1 do
	begin
	if ((ppal^.pal[i].Red  <>0) or
	    (ppal^.pal[i].Green<>0)) or
	    (ppal^.pal[i].Blue <>0) then exit;
	end;
 InvalidPalette:=True;
end;


Procedure FormTCPalette(var ppal:Ppalette);{format True color palette}
var i,j:Word;
    Colors:Word;
begin
 if (ppal^.colors<>256) then exit;

 for i:=0 to Colors-1 do
	begin
	j:=i*255 div (Colors-1);
	ppal^.pal[i].Red  := i and $E0;
	ppal^.pal[i].Green:= (i and $1C) shl 3;
	ppal^.pal[i].Blue := (i and 3) shl 6;
	end;
end;

Procedure ReMapPalAsGray(var obr:picture);
var i:integer;
    qoc,qoc2:array[0..255] of byte;
    OldPal,NewPal:Ppalette;
begin
if (not(obr.valid) or (obr.palette=nil))or(obr.planes>8) then exit;

SortPal(Obr.Palette,qoc);

for i:=0 to obr.palette^.colors-1 do qoc2[qoc[i]]:=i;	{inverzni funkce qoc}
Operation1(obr,ReTabB,addr(qoc2),nil);

OldPal:=Obr.Palette;			{premapovani palety}
Obr.Palette:=nil;
CreatePalette(Obr.palette,Obr.planes);
for i:=0 to OldPal^.Colors-1 do
	begin
	Obr.Palette^.pal[i]:=OldPal^.pal[qoc[i]];
	end;
NewPal:=Obr.Palette;
Obr.Palette:=OldPal;
ErasePalette(Obr.palette);
Obr.Palette:=NewPal;
end;


{Non destructive sorting palette- results are stored in qoc}
Procedure SortPal(pal:PPalette;var qoc:array of byte);
var i,j,k:integer;
    p1,p2:^RGB;
begin
for i:=0 to Pal^.Colors-1 do qoc[i]:=i;

for i:=0 to Pal^.Colors-2 do
   for j:=0 to Pal^.Colors-2-i do
	begin
	p1:=addr(pal^.pal[qoc[j]]);
	p2:=addr(pal^.pal[qoc[j+1]]);

{	if p1^.Red+p1^.Green+p1^.Blue>p2^.Red+p2^.Green+p2^.Blue then
		begin
		k:=qoc[j];
		qoc[j]:=qoc[j+1];
		qoc[j+1]:=k;
		end;{}
	if 3*p1^.Red+6*p1^.Green+p1^.Blue>3*p2^.Red+6*p2^.Green+p2^.Blue then
		begin
		k:=qoc[j];
		qoc[j]:=qoc[j+1];
		qoc[j+1]:=k;
		end;{}
	end;

end;


Function NearAvailPln(n:Word):Word;
begin
  NearAvailPln:=1;
  if n=1 then exit;
  NearAvailPln:=2;
  if n<=2 then exit;
  NearAvailPln:=4;
  if n<=4 then exit;
  NearAvailPln:=8;
  if n<=8 then exit;
  NearAvailPln:=16;
  if n<=16 then exit;
  NearAvailPln:=24;
  if n<=24 then exit;
  NearAvailPln:=32;
end;
{-------------------------------------------------------}


Procedure view(var p:AbstractPicture);
begin
{$ifdef graph}
 p.View(nil);
{$endif}
end;

Constructor picture.Init;
begin
 typ:='B';
 filename:=nil;
 data:=nil;
 palette:=nil;
 x:=0;
 y:=0;
end;

Destructor picture.Done;
begin
 Erase;
 if filename<>nil then
	begin
	dispose(filename);
	filename:=nil;
	end;
end;


Function Picture.Valid:Boolean;
begin
 Valid:=data<>nil;
end;


Procedure picture.Erase;
var i:Word;
    ldblk:Word;
    {$ifdef StackAllocations}q:Word;{$endif}
begin
 ErasePalette(palette);
 if data=nil then exit;
 ldblk:=(longint(planes)*x+7) div 8;
 {$ifdef StackAllocations}
 if ldblk>0 then q:=65520 div ldblk
	    else q:=1;  		{i mod q is always 0 here}

 for i:=0 to y-1 do
    begin
    if i mod q = 0 then
       if data^[i]<>nil then freemem(data^[i],ldblk);
    end;

 {$else}
 for i:=0 to y-1 do
	if data^[i]<>nil then freemem(data^[i],ldblk);
 {$endif}
 freemem(data,4*y);
 data:=nil;
 x:=0;y:=0;
end;


Procedure Picture.Create_(SizeX,SizeY:Word;pln:Word;SameP:PAbstractPicture);
begin
 if SameP<>nil then
	begin
	if SizeX=0 then SizeX:=SameP^.x;
	if SizeY=0 then SizeY:=SameP^.y;
	if pln=0 then   pln:=SameP^.planes;
	end;
 Create(SizeX,SizeY,pln);
 if SameP^.Palette<>nil then
	begin
	CreatePalette(palette,planes);
	Move(SameP^.palette^,palette^,3*palette^.colors+sizeof(word));
	end;
end;


Procedure Picture.Create(SizeX,SizeY:Word;pln:Word);
var i:Word;
    LdBlk:Longint;
    {$ifdef StackAllocations}
    q:Word;
    {$endif}
label Vypln,Failed;
begin
 ldblk:=((longint(pln) and $FF)*SizeX+7) div 8;
 if ((Data<>nil)and(x=SizeX))and((y=SizeY)and((pln and $FF)=planes)) then
	begin			{stejne rozmery- skoda nove alokace}
	ErasePalette(palette);
	goto Vypln;
	end;

 Erase;
 if(ldblk>65520) then
   begin
   WriteError(ErrData);
   exit;	{row size overflow}
   end;
 x:=SizeX;
 y:=SizeY;
 planes:=pln and $FF;
 Typ:='G';
 if ((SizeX=0)or(SizeY=0))or(planes=0) then exit;

 if(longint(4)*SizeY>65520) then
   begin
   WriteError(ErrData);
   exit;		{row amount overflow}
   end;
 GetMem(data,4*SizeY);		{alokace pameti pro radky}
 if Data=nil then exit;
 fillchar(data^,4*SizeY,0);
{$ifdef StackAllocations}
   i:=0;
   q:=65520 div LdBlk;
   while i<=y-1 do
     begin
       if MaxAvail<Ldblk+8 then	{neni dostatek volne pameti}
		begin
Failed:		WriteError(ErrMem);
		Erase;
		exit;
		end;

	if i mod q = 0 then		{aggregate more allocations into one block}
	  GetMem(data^[i],Ldblk*q)
	else
	  data^[i]:=ptr(seg(data^[i-1]^),ofs(data^[i-1]^)+LdBlk);

	{writeln(i,' ',MaxAvail);{}
	if(data^[i]=nil) then goto Failed;
	inc(i);
	end;
{$else}
 for i:=0 to y-1 do
	begin
	{write(' Ma:',MaxAvail,' ');{}
	if MaxAvail<Ldblk+8 then	{neni dostatek volne pameti}
		begin
Failed:		WriteError(ErrMem);
		Erase;
		exit;
		end;
	GetMem(data^[i],Ldblk);
	if(data^[i]=nil) then goto Failed;
	end;
{$endif}

Vypln:				{vyplneni obrazku 0}
 if Data=nil then exit;
 if (pln and NoFill)=0 then
	for i:=0 to y-1 do Fillchar(data^[i]^,LdBlk,0); {vyplneni pameti}

end;


Procedure AssignPicture(var p:AbstractPicture;const name:pathStr);
begin
 if p.filename=nil then new(p.filename);
 p.filename^:=name;
end;


Procedure LoadPicture(var p:AbstractPicture;const s:PathStr;AlineProc:PAbstractLineProc);
var ext:string[4];
    _FileMode:Byte;
    i:Byte absolute _FileMode;
begin
 if s<>'' then AssignPicture(p,s);
 if p.filename=nil then exit;
 ext:=copy(p.filename^,length(p.filename^)-2,3);
 if(ext[1]='.') then ext:=copy(ext,2,2);
 for i:=1 to 4 do ext[i]:=upcase(ext[i]);
 _Filemode:=FileMode;
 Filemode:=0;
 p.Load(ext,AlineProc);
 Filemode:=_FileMode;
end;


Procedure Picture.Load(ext:extStr;AlineProc:PAbstractLineProc);
var res:integer;
begin
 res:=0;
 if (ext='ART') then res:=LoadPictureART(self,AlineProc);
 if (ext='BMP')or(ext='RLE') then res:=LoadPictureBMP(self,AlineProc);
 if (ext='CUT') then res:=LoadPictureCUT(self,AlineProc);
{$ifdef ftgr}
 if ext='FTG' then res:=LoadPictureFTG(self,AlineProc);
 if ext='GIF' then res:=LoadPictureGIF(self,AlineProc);
{$endif}
 if ext='HRZ' then res:=LoadPictureHRZ(self,AlineProc);
 if ext='ICO' then res:=LoadPictureICO(self,AlineProc);
{$ifdef jpg}
 if ext='JPG' then res:=LoadPictureJPG(self,AlineProc);
{$endif}
 if ext='MAC' then res:=LoadPictureMAC(self,AlineProc);
 if ext='MAT' then res:=LoadPictureMAT(self,AlineProc);
 if ext='OKO' then res:=LoadPictureOKO(self,AlineProc);
 if ext='PCX' then res:=LoadPicturePCX(self,AlineProc);
 if ext='PNG' then res:=LoadPicturePNG(self,AlineProc);
 if ext='RAS' then
	begin
	res:=LoadPictureSUNRAS(self,AlineProc);
	if data=nil then LoadPictureRAS(self,AlineProc);
	end;
 if ((ext='PBM')or(ext='PGM'))or(ext='PPM') then res:=LoadPicturePBM(self,AlineProc);
 if (ext='PS') or (ext='EPS') then res:=LoadPicturePS(self,AlineProc);
 if ext='TGA' then res:=LoadPictureTGA(self,AlineProc);
 if ext='TIF' then res:=LoadPictureTif(self,AlineProc);
 if ext='TXT' then res:=LoadPictureTXT(self,AlineProc);
 if ext='WPG' then res:=LoadPictureWPG(self,AlineProc);

 if (res<>0)and(res<>ErrAnother) then	{pri nahravani doslo k chybe - uz nic nezkousej}
	begin
	if res>0 then WriteError(ErrRDDisk)
		 else WriteError(res);
	if EraseBadImage then Erase;
	exit;
	end;

 if data=nil then
	begin
	res:=LoadPictureBMP(self,AlineProc);	{zkousej nahravat jednotlive typy obrazku}
	if (data<>nil)or(res<>ErrAnother) then exit;
	res:=LoadPictureOKO(self,AlineProc);
	if (data<>nil)or(res<>ErrAnother) then exit;
	res:=LoadPicturePCX(self,AlineProc);
	if (data<>nil)or(res<>ErrAnother) then exit;
	LoadPicturePS(self,AlineProc);
	if data<>nil then exit;
	LoadPictureSUNRAS(self,AlineProc);
{$ifdef ftgr}
	if data<>nil then exit;
	LoadPictureFTG(self,AlineProc);
	if data<>nil then exit;
	LoadPictureGIF(self,AlineProc);
{$endif}
	if data<>nil then exit;
	LoadPicturePBM(self,AlineProc);
	if data<>nil then exit;
	LoadPictureTXT(self,AlineProc);
	if data<>nil then exit;
	LoadPictureTIF(self,AlineProc);
	if data<>nil then exit;
	LoadPictureWPG(self,AlineProc);
	if data<>nil then exit;
	LoadPictureTGA(self,AlineProc);
	if data<>nil then exit;

	  {these fileformats are purely indentified}
	LoadPictureRAS(self,AlineProc);
	if data<>nil then exit;
	LoadPictureCUT(self,AlineProc);
	if data<>nil then exit;

	  {the last possible is to try download weak formats like a plain RAS format}
	if (ext='RAW')or(ext='RAS') then res:=LoadPictureRAS_Danger(self,AlineProc);
	if data<>nil then exit;
	if ext='HRZ' then res:=LoadPictureHRZ(self,AlineProc);
	end;
 if data=nil then WriteError(ErrFormat);
end;


Function SavePictureART(var p:picture;AlineProc:PAbstractLineProc):Boolean;
var f:file;
    Ldblk:Word;
    i,dummy:Word;
    k:byte;
    Formater:PFormStruct;
    TempData:^byte;
label FINISH;
begin
 SavePictureART:=False;
 if p.data=nil then exit;

 TempData:=nil;

 assign(f,p.filename^);
 filemode:=2;
 rewrite(f,1);
 if IOresult<>0 then exit;

 dummy:=0;
 BlockWrite(f,dummy,2,Ldblk);
 BlockWrite(f,p.x,2,Ldblk);
 BlockWrite(f,dummy,2,Ldblk);
 BlockWrite(f,p.y,2,Ldblk);

 ldblk:=(p.x+7) div 8;
 k:=(-ldblk)and $1;

 if(p.planes<>1) then
   begin
   getmem(TempData,ldblk);
   Formater:=InitFormatter(p.x, p.typ, p.Planes,
			      'G',     1,        0);
   if(Formater=nil) then goto FINISH; {cannot be converted}
   if p.typ='P' then Formater^.Palette:=addr(p.Palette^.pal[0]);
   end;

 for i:=0 to p.y-1 do
	begin
	if(TempData<>nil) then
	  begin
	  Formater^.conv(Formater,p.Data^[i],TempData);
	  BlockWrite(f,TempData^,LdBlk);
	  end
	else
	  BlockWrite(f,p.data^[i]^,LdBlk);

	if AlineProc<>nil then AlineProc^.NextLine;
	end;

FINISH:
 if(TempData<>nil) then FreeMem(TempData,ldblk);

 close(f);
 if IOResult<>0 then exit;
 SavePictureART:=True;
end;


Function SavePictureBMP(var p:picture;AlineProc:PAbstractLineProc):boolean;
var f:file;
    delka:Longint;
    Ldblk:Word;
    Header:BMPHeader;
    Info:BMPInfo_Coreinfo;
    k:Byte;
    i:integer;
    gray:Boolean;
    palitem:RGBQuad;
label KONEC;
begin
 SavePictureBMP:=False;
 if not(p.planes in [1,4,8,24]) then exit;	{nepodporovany format}

 if AlineProc<>nil then
		AlineProc^.InitPassing(p.y*p.planes,'Saving BMP');
 assign(f,p.filename^);
 rewrite(f,1);
 if(IOresult<>0) then exit;

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 fillchar(Header,Sizeof(Header),0);
 Header.bfType:='BM';
 Header.bfOffBits:=Sizeof(Header)+Sizeof(Info)+1 shl (p.planes + 2);
 Header.bfSize:=Header.bfOffBits+ p.y*((ldblk+3) and $FFFC);

 fillchar(Info,Sizeof(Info),0);
 Info.biSize:=40;
 Info.biWidth:=p.x;
 Info.biHeight:=p.y;
 Info.biplanes:=1;
 Info.biBitCount:=p.planes;
 Info.biCompression:=0;		{kompresi neumim}
 Info.biSizeImage:=Header.bfSize-Header.bfOffBits;
 if (p.planes=4)or(p.planes=8) then Info.BiClrUsed:=1 shl (p.planes);

 BlockWrite(f,Header,sizeof(Header),i);
 BlockWrite(f,Info,sizeof(Info),i);
 if IOresult<>0 then Goto konec;

 if (p.planes=4)or(p.planes=8) then
       begin	 		{paleta}
       gray:=p.palette=nil;
       if gray then CreatePalette(p.palette,p.planes);
       palItem.RGBReserved:=0;
       for K:=0 to p.palette^.Colors-1 do
	 begin
	 palItem.RGBRed:=  p.palette^.pal[K].Red;
	 palItem.RGBGreen:=p.palette^.pal[K].Green;
	 palItem.RGBBlue:= p.palette^.pal[K].Blue;
	 BlockWrite(F,palitem,sizeof(palitem),i);
	 end;
       if Gray then ErasePalette(p.palette);
       end;

 Seek(f,Header.bfOffbits);
 k:=(-ldblk)and $3;
 for i:=p.y-1 downto 0 do
	begin
	if p.planes=24 then RGB_BGR(p.x,p.data^[i]);
	BlockWrite(f,p.data^[i]^,LdBlk);
	if p.planes=24 then RGB_BGR(p.x,p.data^[i]);
	BlockWrite(f,Header.bfReserved1,k);	{zapis nul do konce radku}
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
KONEC:
 close(f);
 if IOResult=0 then SavePictureBMP:=True;
end;


Function SavePictureICO(var p:picture;AlineProc:PAbstractLineProc):boolean;
var f:file;
    Ldblk1,Ldblk,status:Word;
    i:Word;
    Header:IconHeader;
    Entry:IconDirectoryEntry;
    Info:BMPInfo_Coreinfo;
    RGB:RGBQuad;
    Nopalette:Boolean;
    Dummy:pointer;
label KONEC;
begin
 SavePictureICO:=False;
 if not(p.Valid) then exit;
 if (p.planes>8) or ((p.x>255) or (p.y>255)) then exit; {image is too big to fit into the icon}

 assign(f,p.filename^);
 rewrite(f,1);
 if IOresult<>0 then
	begin
	SavePictureICO:=false;
	exit;
	end;

 Header.idReserved:=0;
 Header.idType:=1;
 Header.idCount:=1;
 BlockWrite(f,Header,sizeof(Header),status);

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 ldblk1:=(longint(1)*p.x+7) div 8;

 with Entry do
    begin
    bWidth:=p.x;
    bHeight:=p.y;
    bColorCount:=word(1) shl p.planes;
    if p.planes=8 then bColorCount:=255;
    bReserved:=0;
    wPlanes:=0;
    wBitCount:=0;
    dwImageOffset:= sizeof(Entry) + sizeof(Header);
    dwBytesInRes:=bHeight*(ldblk+ldblk1) + (word(1) shl p.planes)*SizeOf(RGB) + sizeof(Info);
    end;

 with Info do
    begin
    biSize:=40;
    biWidth:=p.x;
    biHeight:=2*p.y;
    biPlanes:=1;
    biBitCount:=p.planes;
    biCompression:=0;
    biSizeImage:=p.y*(ldblk+ldblk1);
    biXPelsPerMeter:=0;
    biYPelsPerMeter:=0;
    biClrUsed:=0;
    biClrImportant:=0;
    end;


 BlockWrite(f,Entry,sizeof(Entry),status);
 BlockWrite(f,Info,sizeof(Info),status);

 if AlineProc<>nil then
	AlineProc^.InitPassing(2*p.y,'Saving ICO');

 Nopalette:=p.palette=nil;
 if NoPalette then CreatePalette(p.palette,p.Planes);
 for i:=0 to word(1) shl p.planes - 1 do
	begin
	RGB.RGBRed:=p.palette^.pal[i].Red;
	RGB.RGBGreen:=p.palette^.pal[i].Green;
	RGB.RGBBlue:=p.palette^.pal[i].Blue;
	BlockWrite(f,RGB,SizeOf(RGB));
	end;
 if NoPalette then ErasePalette(p.palette);

 for i:=p.y-1 downto 0 do	{XOR part}
	begin
	Blockwrite(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

 getmem(dummy,ldblk1);
 fillchar(dummy^,ldblk1,$00);
 for i:=p.y-1 downto 0 do	{AND part is empty}
	begin
	Blockwrite(f,Dummy^,LdBlk1);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
 freemem(dummy,ldblk1);

KONEC:
 close(f);
 if IOResult=0 then SavePictureICO:=true;
end;  {SaveICO}


{This procedure saves image data into MATLAB MAT file}
Function SavePictureMAT(var p:picture;AlineProc:PAbstractLineProc):Boolean;
const mxCELL_CLASS = 1;		{ cell array }
      mxSTRUCT_CLASS = 2;	{ structure }
      mxOBJECT_CLASS = 3;	{ object }
      mxCHAR_CLASS = 4;		{ character array }
      mxSPARSE_CLASS = 5;	{ sparse array }
      mxDOUBLE_CLASS = 6;	{ double precision array }
      mxSINGLE_CLASS = 7;	{ single precision floating point }
      mxINT8_CLASS = 8;		{ 8 bit signed integer }
      mxUINT8_CLASS = 9;	{ 8 bit unsigned integer }
      mxINT16_CLASS = 10;	{ 16 bit signed integer }
      mxUINT16_CLASS = 11;	{ 16 bit unsigned integer }
      mxINT32_CLASS = 12;	{ 32 bit signed integer }
      mxUINT32_CLASS = 13;	{ 32 bit unsigned integer }
      mxINT64_CLASS = 14;	{ 64 bit signed integer }
      mxUINT64_CLASS = 15;	{ 64 bit unsigned integer }
      mxFUNCTION_CLASS = 16;    { Function handle }

      miINT8 = 1;		{ 8 bit signed }
      miUINT8 = 2;		{ 8 bit unsigned }
      miINT16 = 3;		{ 16 bit signed }
      miUINT16 = 4;		{ 16 bit unsigned }
      miINT32 = 5;		{ 32 bit signed }
      miUINT32 = 6;		{ 32 bit unsigned }
      miSINGLE = 7;		{ IEEE 754 single precision float }
      miRESERVE1 = 8;
      miDOUBLE = 9;		{ IEEE 754 double precision float }
      miRESERVE2 = 10;
      miRESERVE3 = 11;
      miINT64 = 12;		{ 64 bit signed }
      miUINT64 = 13;		{ 64 bit unsigned }
      miMATRIX = 14;		{ MATLAB array }
      miCOMPRESSED = 15;	{ Compressed Data }
      miUTF8 = 16;		{ Unicode UTF-8 Encoded Character Data }
      miUTF16 = 17;		{ Unicode UTF-16 Encoded Character Data }
      miUTF32 = 18;		{ Unicode UTF-32 Encoded Character Data }

      FLAG_COMPLEX = $800;
      FLAG_GLOBAL =  $400;
      FLAG_LOGICAL = $200;
var f:file;
    iy:WORD;
    padding:BYTE;
    IsColor:boolean;
    MATLAB_HDR: array [0..183] of BYTE;
    DataSize: longint;
    Ldblk:Word;
    ptrLineX:^LinePict;
    ix:word;
    clr:BYTE;

  procedure PutLong(p:pointer; ll: longint );
  var long: ^longint absolute p;
  begin
    long^:=ll;
  end;

  procedure BuildMAT_TXT;
  var s:string;
  begin
  {const struct tm *t;
  time_t current_time;

  current_time=time((time_t *) NULL);
  t=localtime(&current_time);}
    s:='MATLAB 5.0 MAT-file, Platform: DOS, Created on: ';
    move(s[1],MATLAB_HDR,length(s));
    MATLAB_HDR[$7D] :=   1;
    MATLAB_HDR[$7E] := BYTE('I');
    MATLAB_HDR[$7F] := BYTE('M');
  end;


label FINISH;
begin
  padding:=0;
  SavePictureMAT:=False;
  if p.data=nil then exit;

  assign(f,p.filename^);
  filemode:=2;
  rewrite(f,1);
  if IOresult<>0 then exit;

  IsColor := ((p.planes=24)and(p.typ='C'));

  DataSize := longint(p.x) * longint(p.y);
  if(IsColor) then
    DataSize := DataSize * 3
  else
    if(p.Planes>8) then DataSize := DataSize * 2;

  padding := (BYTE(DataSize-1) and 7) xor 7;

  fillchar(MATLAB_HDR,124,' ');
  fillchar(MATLAB_HDR[124],sizeof(MATLAB_HDR)-124,0);

  BuildMAT_TXT;

  PutLong(addr(MATLAB_HDR[$80]), miMATRIX);
  PutLong(addr(MATLAB_HDR[$84]), DataSize + 56 + longint(padding));
  MATLAB_HDR[$88]:=$6;
  MATLAB_HDR[$8C]:=$8;
  MATLAB_HDR[$90]:=$6;
  MATLAB_HDR[$98]:=$5;
  if(IsColor) then MATLAB_HDR[$9C] := 12
	      else MATLAB_HDR[$9C] := $8;         {DimFlag}
  PutLong(addr(MATLAB_HDR[$A0]), p.y); 	{Rotate image 90 degs}
  PutLong(addr(MATLAB_HDR[$A4]), p.x);  {Rotate image 90 degs}
  MATLAB_HDR[$A8]:=1;
  MATLAB_HDR[$AA]:=1;   		{NameFlag}
  MATLAB_HDR[$AC]:=BYTE('M');           {matrix name}
  if(IsColor) then MATLAB_HDR[$B0]:=2	{BYTE}
  else
    begin
    if(p.Planes<=8) then
      MATLAB_HDR[$B0]:=2		{BYTE}
    else
      MATLAB_HDR[$B0]:=4;		{WORD}
    end;

  PutLong(addr(MATLAB_HDR[$B4]), DataSize);

  if(IsColor) then
    begin
    Blockwrite(f,MATLAB_HDR,sizeof(MATLAB_HDR)-16,LdBlk);
    DataSize := 3;       {z order}
    Blockwrite(f,DataSize,4,LdBlk);
    DataSize := 0;		{Unknown 5}
    Blockwrite(f,DataSize,4,LdBlk);
    Blockwrite(f,MATLAB_HDR[sizeof(MATLAB_HDR)-16],16,LdBlk);

    getmem(ptrLineX,p.y);

    for Clr:=0 to 2 do
      begin
      for ix:=0 to p.x-1 do
	begin
	for iy:=0 to p.y-1 do
	  begin
	  ptrLineX^.b[iy] := (longint(Pixel(p,ix,iy)) shr (8*Clr)) and $FF;
	  end;
	Blockwrite(f,ptrLineX^,p.y,LdBlk);
	end
      end;
      if(ptrLineX<>nil) then
	  begin
	  freemem(ptrLineX,p.y);ptrLineX:=nil;
	  end
    end
  else
    begin
    Blockwrite(f,MATLAB_HDR,sizeof(MATLAB_HDR),LdBlk);

    if(p.Planes<=8) then
      begin
      getmem(ptrLineX,p.y);
      for ix:=0 to p.x-1 do
	begin
	for iy:=0 to p.y-1 do
	  begin
	  ptrLineX^.b[iy] := Pixel(p,ix,iy); {Gray image 8 bit, rotated 90 degs}
	  end;
	Blockwrite(f,ptrLineX^,p.y,LdBlk);
	end;
	if(ptrLineX<>nil) then
	  begin
	  freemem(ptrLineX,p.y);ptrLineX:=nil;
	  end;
      end
    else
      begin
      getmem(ptrLineX, 2*p.y);
      for ix:=0 to p.x-1 do
	begin
	for iy:=0 to p.y-1 do
	  begin
	  ptrLineX^.w[iy] := Pixel(p,ix,iy); {Gray image 16 bit, rotated 90 degs}
	  end;
	Blockwrite(f,ptrLineX^,2*p.y,LdBlk);
	end;
      if(ptrLineX<>nil) then
	  begin
	  freemem(ptrLineX,2*p.y);ptrLineX:=nil;
	  end
      end
    end;

  DataSize:=0;
  while(padding>0) do
    begin
    dec(padding);
    Blockwrite(f,DataSize,1,LdBlk);
    end;
FINISH:
 close(f);
 if IOResult<>0 then exit;
 SavePictureMAT:=True;
end;


Function SavePictureOKO(var p:picture;AlineProc:PAbstractLineProc):Boolean;
var f:file;
    Ldblk:Word;
    i:Word;
    Header:OkoHeader;
    identif: array[1..21] of char absolute Header;
    s1:string[10];
label KONEC;
begin
 SavePictureOKO:=False;
 if p.data=nil then exit;
 fillchar(Header,Sizeof(Header),#0);
 Header.Rows:=p.x;
 Header.Cols:=p.y;
 Header.Ver:=3;
 Header.Modif:=5;
 Header.Levels:=1 shl p.planes;
 if(p.planes=16) then Header.Levels:=$FFFF;
 identif:='OBR2 Image File v3.05';
 assign(f,p.filename^);
 filemode:=2;
 rewrite(f,1);
 if IOresult<>0 then exit;
 Blockwrite(f,Header,sizeof(Header),Ldblk);

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 for i:=0 to p.y-1 do
	begin
	BlockWrite(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

KONEC:
 close(f);
 if IOResult<>0 then exit;
 SavePictureOKO:=True;
end;

Function SavePicturePCX(var p:picture;AlineProc:PAbstractLineProc):boolean;
const Mask=$C0;
      MaxCnt=63;
type buffer=array[0..65500] of byte;
var
  F:file;
  W:word;
  X,Y,OC,C,Cnt:word;
  PcxFile:PcxHeader;
  data:^buffer;
  ptrb:^byte;
  datapos:Word;
  gray:Boolean;
  bbuf:^byte;
  Aplane:Byte;
begin
  SavePicturePCX:=false;
  if p.data=nil then exit;
  gray:=p.palette=nil;
  bbuf:=nil;

  FillChar(PCXFile,sizeof(PCXFile),0);
  PCXFile.Id0:=10;
  PCXFile.version:=$5;
  PCXFile.Encoding:=$1;
  PCXFile.BitPerPix:=1;
  PCXFile.x0:=0;
  PCXFile.y0:=0;
  PCXFile.x1:=p.X-1;
  PCXFile.y1:=p.Y-1;
  PCXFile.NumPlanes:=p.planes;
  PCXFile.BytesPerLine:=PCXFile.x1-PCXFile.x0+1;
  PCXFile.PaletteInfo:=1;

  case p.Planes of 1:PCXFile.BytesPerLine:=(PCXFile.BytesPerLine+7) shr 3;
		   2:begin
		     if gray then CreatePalette(p.palette,p.planes);
		     move(p.palette^.pal[0],PCXFile.ColorMap,3*4);
		     if gray then ErasePalette(p.palette);
		     GetMem(bbuf,(p.x+7)shr 3);
		     PCXFile.BytesPerLine:=(PCXFile.BytesPerLine+7) shr 3;
		     end;
		   4:begin
		     if gray then CreatePalette(p.palette,p.planes);
		     move(p.palette^.pal[0],PCXFile.ColorMap,3*16);
		     if gray then ErasePalette(p.palette);
		     GetMem(bbuf,(p.x+7)shr 3);
		     PCXFile.BytesPerLine:=(PCXFile.BytesPerLine+7) shr 3;
		     end;
		   8:begin
		     PCXFile.BitPerPix:=8;
		     PCXFile.NumPlanes:=1;
		     end;
		  24:begin
		     PCXFile.BitPerPix:=8;
		     PCXFile.NumPlanes:=3;
		     GetMem(bbuf,p.x);
		     end;
		  else exit;
	      end;

  Assign(F,p.FileName^);
  Rewrite(F,1);
  if IOResult<>0 then exit;
  BlockWrite(F,PCXFile,128,W);

  getmem(data,2*PCXFile.BytesPerLine);

  for Y:=0 to P.Y-1 do
    begin

    for Aplane:=1 to PCXFile.NumPlanes do
      begin
      datapos:=0;
      Cnt:=0;
      ptrb:=pointer(p.data^[Y]);

      if PCXFile.NumPlanes<>1 then
	   begin
	   if PCXFile.BitPerPix=1 then peel1plane(p,Y,Aplane,bbuf);
	   if PCXFile.BitPerPix=8 then peelB(p.X,addr(p.data^[Y]^.b[Aplane-1]),bbuf,3);
	   ptrb:=pointer(bbuf);
	   end;


      for X:=0 to PCXFile.BytesPerLine-1 do
	   begin
	   C:=ptrb^;
	   inc(ptrb);

	   if (Cnt<>0)and((OC<>C)or(Cnt=MaxCnt)) then
	       begin
	       if (Cnt<>1)or((OC and Mask)=Mask) then {pridani prefixu}
			   begin
			   data^[datapos]:=Cnt or Mask;
			   inc(datapos);
			   end;
	       data^[datapos]:=OC;
	       inc(datapos);
	       Cnt:=0;
	       end;
	   OC:=C;
	   inc(Cnt);
	   end;
       if (Cnt<>0) then	{konec radku}
	   begin
	   if (Cnt<>1)or((OC and Mask)=Mask) then {pridani prefixu}
			   begin
			   data^[datapos]:=Cnt or Mask;
			   inc(datapos);
			   end;
	   data^[datapos]:=OC;
	   inc(datapos);
	   Cnt:=0;
	   end;
       BlockWrite(F,Data^,datapos,W);
       end;
  if AlineProc<>nil then AlineProc^.NextLine;
  end;

  freemem(data,2*PCXFile.BytesPerLine);

  if p.planes=8 then
       begin
       W:=12;		{paleta}
       BlockWrite(F,W,1,W);
       if gray then CreatePalette(p.palette,p.planes);
       for X:=0 to 255 do
	 begin
	 BlockWrite(F,p.palette^.pal[X],3,W);
	 end;
      if gray then ErasePalette(p.palette);
      end;

  if bbuf<>nil then
	begin
	if PCXFile.BitPerPix=1 then FreeMem(bbuf,(p.x+7)shr 3);
	if PCXFile.BitPerPix=8 then FreeMem(bbuf,p.x);
	end;

  Close(F);
  if IOResult<>0 then exit;
  SavePicturePCX:=true;
end;


Function SavePicturePS(var p:picture;AlineProc:PAbstractLineProc):boolean;
var F:text;
    X,Y,BytesPerLine:word;
    ptrb:^byte;
    ColorMode:Byte;
    X_lb_corner,Y_lb_corner,PS_width,PS_height:real;

begin
  SavePicturePS:=false;
  if p.data=nil then exit;
  ColorMode:=0;		{gray}
  if((p.planes=24)and(p.typ='C')) then ColorMode:=1;
  if((p.planes<=8)and(p.typ='P')) then ColorMode:=2;

  Assign(F,p.FileName^);
  Rewrite(F);
  if IOResult<>0 then exit;

  X_lb_corner:=0;Y_lb_corner:=0;
  PS_width:=p.x;PS_height:=p.y;
  x:=round(PS_width) div 595;
  if(x>0) then
	begin
	PS_width:=PS_width / x;
	PS_height:=PS_height /x;
	end;

  writeln(F,
     '%!PS-Adobe-2.0 EPSF-2.0'#13#10,
     '%%Title: ',p.FileName^,#13#10,
     '%%Creator: Pictures Version ',PicturesVer shr 8,'.',PicturesVer and $FF,' Rev: 1/6/2009  -  by Jaroslav Fojtik'#13#10,
     '%%BoundingBox: ',X_lb_corner:2:2,' ',Y_lb_corner:2:2,' ',PS_width:2:2,' ',PS_height:2:2,#13#10,
     '%%Pages: 1'#13#10,
     '%%DocumentFonts:'#13#10,
     '%%EndComments'#13#10,
     '%%EndProlog'#13#10,
     #13#10,
     '%%Page: 1 1',
     #13#10);

  if(ColorMode>=1) then
  writeln(F,
     '% define ''colorimage'' if it isn''t defined'#13#10,
     '%   (''colortogray'' and ''mergeprocs'' come from xwd2ps'#13#10,
     '%     via xgrab)'#13#10,
     '/colorimage where   % do we know about ''colorimage''?'#13#10,
     '  { pop }           % yes: pop off the ''dict'' returned'#13#10,
     '  {                 % no:  define one'#13#10,
     '  /colortogray {  % define an RGB->I function'#13#10,
     '    /rgbdata exch store    % call input ''rgbdata'''#13#10,
     '    rgbdata length 3 idiv'#13#10,
     '    /npixls exch store'#13#10,
     '    /rgbindx 0 store'#13#10,
     '    0 1 npixls 1 sub {'#13#10,
     '      grays exch'#13#10,
     '      rgbdata rgbindx       get 20 mul    % Red'#13#10,
     '      rgbdata rgbindx 1 add get 32 mul    % Green'#13#10,
     '      rgbdata rgbindx 2 add get 12 mul    % Blue'#13#10,
     '      add add 64 idiv      % I = .5G + .31R + .18B'#13#10,
     '      put'#13#10,
     '      /rgbindx rgbindx 3 add store'#13#10,
     '    } for'#13#10,
     '    grays 0 npixls getinterval'#13#10,
     '  } bind def'#13#10,
     #13#10,
     '% Utility procedure for colorimage operator.'#13#10,
     '% This procedure takes two procedures off the'#13#10,
     '% stack and merges them into a single procedure.'#13#10,
     #13#10,
     '/mergeprocs { % def'#13#10,
     '  dup length'#13#10,
     '  3 -1 roll'#13#10,
     '  dup'#13#10,
     '  length'#13#10,
     '  dup'#13#10,
     '  5 1 roll'#13#10,
     '  3 -1 roll'#13#10,
     '  add'#13#10,
     '  array cvx'#13#10,
     '  dup'#13#10,
     '  3 -1 roll'#13#10,
     '  0 exch'#13#10,
     '  putinterval'#13#10,
     '  dup'#13#10,
     '  4 2 roll'#13#10,
     '  putinterval'#13#10,
     '} bind def'#13#10,
     '/colorimage { % def'#13#10,
     '  pop pop     % remove ''false 3'' operands'#13#10,
     ' {colortogray} mergeprocs'#13#10,
     'image'#13#10,
     '} bind def'#13#10,
     '} ifelse          % end of ''false'' case'#13#10);

if(ColorMode=2) then
begin
  writeln(F,
		'% rlecmapimage expects to have ''w h bits matrix'' on stack'#13#10,
		'/rlecmapimage {'#13#10,
		'  /buffer 1 string def'#13#10,
		'  /rgbval 3 string def'#13#10,
		'  /block  384 string def'#13#10,
		''#13#10,
		'  % proc to read a block from file, and return RGB data'#13#10,
		'  { currentfile buffer readhexstring pop'#13#10,
		'    /bcount exch 0 get store'#13#10,
		'    bcount 128 ge'#13#10,
		'    {  % it''s a non-run block'#13#10,
		'      0 1 bcount 128 sub'#13#10,
		'      { currentfile buffer readhexstring pop pop'#13#10,
		''#13#10,
		'        % look up value in color map'#13#10,
		'	 /rgbval cmap buffer 0 get 3 mul 3 getinterval store'#13#10,
		''#13#10,
		'	 % and put it in position i*3 in block'#13#10,
		'	 block exch 3 mul rgbval putinterval'#13#10,
		'      } for'#13#10,
		'      block  0  bcount 127 sub 3 mul  getinterval'#13#10,
		'    }'#13#10,
		''#13#10,
		'    { % else it''s a run block'#13#10,
		'      currentfile buffer readhexstring pop pop'#13#10,
		''#13#10,
		'      % look up value in colormap'#13#10,
		'      /rgbval cmap buffer 0 get 3 mul 3 getinterval store'#13#10,
		''#13#10,
		'      0 1 bcount { block exch 3 mul rgbval putinterval } for'#13#10,
		''#13#10,
		'      block 0 bcount 1 add 3 mul getinterval'#13#10,
		'    } ifelse'#13#10,
		'  } % end of proc'#13#10,
		'  false 3 colorimage'#13#10,
		'} bind def'#13#10);
end;

  writeln(F,
     '% remember original state'#13#10,
     '/origstate save def'#13#10,
     #13#10,
     '% build a temporary dictionary'#13#10,
     '20 dict begin'#13#10,
     #13#10,
     '% define string to hold a scanline''s worth of data'#13#10,
     '/pix ',(p.planes*p.x+7)div 8,' string def'#13#10,
     #13#10,
     '% define space for color conversions'#13#10,
     '/grays ',p.x,' string def  % space for gray scale line'#13#10,
     '/npixls 0 def'#13#10,
     '/rgbindx 0 def'#13#10,
     #13#10,
     '% lower left corner'#13#10,
     X_lb_corner:2:2,' ',Y_lb_corner:2:2,' translate'#13#10,
     #13#10,
     '% size of image (on paper, in 1/72inch coords)'#13#10,
     PS_width:2:2,' ',PS_height:2:2,' scale'#13#10);

if(ColorMode=2) then
begin
  write(F,
	'% define the colormap'#13#10,
	'/cmap ',3*p.palette^.colors ,' string def'#13#10,
	'% load up the colormap'#13#10,
	'currentfile cmap readhexstring');  {3x size of a palette}
     for X:=0 to p.palette^.colors-1 do
     begin
	if((X mod 16) = 0) then write(F,#13#10);
	WritexByte(p.palette^.pal[X].Red, F);
	WritexByte(p.palette^.pal[X].Green, F);
	WritexByte(p.palette^.pal[X].Blue, F);
	write(F,' ');
     end;
     write(F,
	#13#10'pop pop  % lose return values from readhexstring'#13#10);
end;

write(F,
     '% dimensions of data'#13#10,
     p.x,' ',p.y,' ');
if(ColorMode=1) then write(F,p.planes div 3)
	      else write(F,p.planes);
writeln(F,#13#10,#13#10,
     '% mapping matrix'#13#10,
     '[',p.x,' 0 0 -',p.y,' 0 ',p.y,']'#13#10,
     #13#10);

if(ColorMode<>2) then
begin
    writeln(F,'{currentfile pix readhexstring pop}');
 if(ColorMode=1) then
     write(F,'false 3 color');
 writeln(F,'image'#13#10);
end
else
  writeln(F,'rlecmapimage'#13#10);

  BytesPerLine:=(longint(p.planes)*p.x+7) div 8;

  for Y:=0 to P.Y-1 do
    begin
    if(ColorMode=2) then	{palette images}
    begin
      for X:=0 to p.X-1 do
	begin
	if(X mod 128 = 0) then
	  begin
	  if(p.X-X > 128) then
	      WritexByte((128-1) or $80, F)
	  else
	      WritexByte((p.X-X-1)or $80, F);
	  end;
	  WritexByte(pixel(p,X,Y), F);
	end
      end
    else
      begin
      ptrb:=pointer(p.data^[Y]);
      for X:=0 to BytesPerLine-1 do
	   begin
	   WritexByte (ptrb^, F);
	   inc(ptrb);
	   end;
      end;
    writeln(F);

    if AlineProc<>nil then AlineProc^.NextLine;
  end;

  writeln(F,
       'showpage'#13#10,
       #13#10,
       '% stop using temporary dictionary'#13#10,
       'end'#13#10,
       #13#10,
       '% restore original state'#13#10,
       'origstate restore'#13#10,
       #13#10,
       '%%Trailer');

  Close(F);
  if IOResult<>0 then exit;
  SavePicturePS:=true;
end;


Function SavePictureRAS(var p:picture;AlineProc:PAbstractLineProc):Boolean;
var f:file;
    delka:Longint;
    Ldblk:Word;
    i:Word;
    Header:RasHeader;
    pal:paletteRAS;
label PalFail;
begin
 SavePictureRAS:=False;
 if not(p.valid) then exit;
 Fillchar(Header,Sizeof(Header),0);
 Fillchar(Header.Name,Sizeof(Header.Name),' ');
 Header.Cols:=p.x;
 Header.Rows:=p.y;
 case p.planes of 1:Header.TypSou:=0;
		  4:if p.palette=nil then Header.TypSou:=3
				     else Header.TypSou:=4;
		  8:if p.palette=nil then Header.TypSou:=1
				     else Header.TypSou:=2;
		 16:Header.TypSou:=6;
		 24:Header.TypSou:=5;
	       else exit;
	    end;

 assign(f,p.filename^);
 rewrite(f,1);
 if(IOresult<>0) then exit;
 BlockWrite(f,Header,sizeof(RasHeader),Ldblk);

 Seek(f,$200);
 ldblk:=(longint(p.planes)*p.x+7) div 8;
 for i:=0 to p.y-1 do
	begin
	BlockWrite(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

 close(f);
 if IOResult<>0 then exit;

 if (p.palette<>nil)and(Header.TypSou in [2,4]) then {jeste zbyva ulozeni palety}
	begin
	assign(f,copy(p.filename^,1,length(p.filename^)-3)+'PAL');
	rewrite(f,1);
	if IOResult<>0 then exit;

	i:=p.palette^.Colors-1;
	blockWrite(f,i,1); {uvodni informace}
	if IOResult<>0 then goto PalFail;

	for i:=0 to p.palette^.Colors-1 do
		begin
		pal.Flag:=i;
		pal.Red:=  p.palette^.pal[i].Red;
		pal.Green:=p.palette^.pal[i].Green;
		pal.Blue:= p.palette^.pal[i].Blue;
		blockWrite(f,pal,sizeof(pal));
		if IOresult<>0 then break;
		end;
PalFail:close(f);
	end;

  if IOresult=0 then SavePictureRAS:=True;
end;


Function SavePictureRAW(var p:picture;AlineProc:PAbstractLineProc):Boolean;
var f:file;
    delka:Longint;
    Ldblk:Word;
    i:Word;
    Header:RasHeader;
    pal:paletteRAS;
label PalFail;
begin
 SavePictureRAW:=False;
 if not(p.valid) then exit;

 assign(f,p.filename^);
 rewrite(f,1);
 if(IOresult<>0) then exit;

 ldblk:=(longint(p.planes)*p.x+7) div 8;
 for i:=0 to p.y-1 do
	begin
	BlockWrite(f,p.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

 close(f);
 if IOResult<>0 then exit;

 if IOresult=0 then SavePictureRAW:=True;
end;


Function SavePictureTXT(var p:picture;AlineProc:PAbstractLineProc):Boolean;
var f:text;
    i,j:Word;
begin
 SavePictureTXT:=False;
 if p.data=nil then exit;

 if AlineProc<>nil then
		AlineProc^.InitPassing(p.y*p.planes,'Saving TXT');
 assign(f,p.filename^);
 rewrite(f);
 if(IOresult<>0) then exit;
 for i:=0 to p.y-1 do
   begin
   for j:=0 to p.x-1 do
		write(f,pixel(p,j,i),' ');
   writeln(f);
   if AlineProc<>nil then AlineProc^.NextLine;
   end;

 close(f);
 if IOResult=0 then SavePictureTXT:=True;
end;


Function SavePicture(var p:AbstractPicture;const s:PathStr;AlineProc:PAbstractLineProc):Boolean;
var i:Byte;
begin
 SavePicture:=False;
 if s<>'' then AssignPicture(p,s);
 if p.filename=nil then exit;
 SavePicture:=p.Save(AlineProc);
end;


Function picture.Save(AlineProc:PAbstractLineProc):Boolean;
var ext:string[4];
    i:Byte;
begin
 Save:=False;
 if Data=nil then exit;
 if AlineProc<>nil then AlineProc^.InitPassing(y,'Saving');
 ext:=copy(filename^,length(filename^)-2,3);
 if(ext[1]='.') then ext:=copy(filename^,length(filename^)-1,2);

 for i:=1 to 4 do ext[i]:=upcase(ext[i]);
 if ext='ART' then Save:=SavePictureART(self,AlineProc);
 if ext='BMP' then Save:=SavePictureBMP(self,AlineProc);
 if ext='ICO' then Save:=SavePictureICO(self,AlineProc);
{$ifdef jpg}if ext='JPG' then Save:=SavePictureJPG(self,AlineProc);{$endif}
 if ext='MAT' then Save:=SavePictureMAT(self,AlineProc);
 if ext='OKO' then Save:=SavePictureOKO(self,AlineProc);
 if ext='PCX' then Save:=SavePicturePCX(self,AlineProc);
 if (ext='PS')or(ext='EPS') then Save:=SavePicturePS(self,AlineProc);
 if ext='RAS' then Save:=SavePictureRAS(self,AlineProc);
 if ext='RAW' then Save:=SavePictureRAW(self,AlineProc);
 if ext='TXT' then Save:=SavePictureTXT(self,AlineProc);
{$ifdef ftgr}if ext='FTG' then Save:=SavePictureFTG(self,AlineProc); {$endif}
end;


Procedure MovePicture(var srP,destP:picture;AlineProc:PAbstractLineProc);
var a:string;
    i,LdBlk:Word;
label KONEC;
begin
 DestP.Erase;		{zruseni predchozich dat}
 if SrP.Data=nil then exit;
 DestP.Create(SrP.x,SrP.y,SrP.Planes or NoFill);
 if DestP.Data=nil then exit;

 ldblk:=(longint(srp.planes)*srp.x+7) div 8;
 for i:=0 to DestP.y-1 do
	begin
	Move(srp.data^[i]^,destP.data^[i]^,LdBlk);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
 if SrP.Palette<>nil then
	begin
	CreatePalette(Destp.palette,DestP.planes);
	Move(srp.palette^,destP.palette^,3*destP.palette^.colors+sizeof(word));
	end;
end;


{Flips an image, type could be V-vertical, H-horizontal or D-diagonal}
Procedure Flip(typ:char;var Obr:picture;AlineProc:PAbstractLineProc);
type pword=^Word;
var p:Pointer;
    ukPixel:pWord absolute p;
    ukPixelP:pWord;
    x,y,w:Word;
    ukRadek:^radekW;
    Spixel:Longint;
begin
if not(Obr.valid) then exit;
typ:=UpCase(Typ);

if (typ='V')or (typ='D') then
  begin
  for y:= 0 to (obr.Y-1) div 2 do
	begin
	p:=obr.Data^[y];
	obr.Data^[y]:=obr.Data^[obr.Y-1-y];
	obr.Data^[obr.Y-1-y]:=p;
	end;
  end;

if (typ='H')or (typ='D') then
  begin
  GetMem(ukRadek,2*Obr.x);
  for y:= 0 to obr.Y-1 do
      begin
      if (Obr.typ='G')or(Obr.typ='B') then
	   begin
	   Obr.FormR(y,ukradek);
	   P:=ukradek;{ukpixel == p}
	   ukPixelP:=ukPixel;
	   inc(ukPixelP,(obr.X-1));

	   for x:= 0 to (obr.X-1)div 2 do
		begin
		w:=ukpixel^;
		ukpixel^:=ukpixelP^;
		ukpixelP^:=w;
		inc(ukPixel);
		dec(ukPixelP);
		end;
	   Obr.RfrmB(y,ukradek);
	   end
	   else begin
		for x:= 0 to (obr.X-1) div 2 do
			begin
			Spixel:=Pixel(obr,x,y);
			SetPixel(obr,x,y,Pixel(obr,obr.X-1-x,y));
			SetPixel(obr,obr.X-1-x,y,SPixel);
			end;
		end;
      end;
  FreeMem(ukRadek,2*Obr.x);
  end;

end;


Procedure Rotate(degrees:integer;var Obr:picture;AlineProc:PAbstractLineProc);
var Fbr:picture;
    x,y:integer;
Label SkipRotate;
begin
  if((degrees=90) or (degrees=270)) then
    begin
    Fbr.Init;
    Fbr.x:=Obr.x;
    Fbr.y:=Obr.y;
    Fbr.typ:=Obr.typ;
    Fbr.planes:=Obr.planes;
    Fbr.data:=Obr.data;		Obr.data:=nil;
    Fbr.palette:=Obr.palette;	Obr.palette:=nil;

    Obr.Erase;
    Obr.Create(Fbr.y,Fbr.x,Fbr.planes);
    if(not Obr.Valid) then
      begin
      goto SkipRotate;		{Fbr destructor must be called}
      end;
    Obr.Typ:=Fbr.Typ;

    for y:= 0 to obr.Y-1 do
      begin
      for x:= 0 to obr.X-1 do
	begin
	  SetPixel(Obr,x,y,Pixel(Fbr,y,x));
	end
      end;

    Obr.palette:=Fbr.palette;	Fbr.palette:=nil;
SkipRotate:
    Fbr.Done;
    end;

  if((degrees=180) or (degrees=270)) then
    begin
    Flip('D',Obr,AlineProc);
    exit;
    end;

end;


Procedure Invert(var Obr:picture;AlineProc:PAbstractLineProc);
var y:Word;
    ldblk:longint;
begin
if not(Obr.valid) then exit;

if Obr.palette<>nil then
	begin
	for y:=0 to Obr.palette^.Colors-1 do
		begin
		Obr.palette^.pal[y].red:=not(Obr.palette^.pal[y].red);
		Obr.palette^.pal[y].green:=not(Obr.palette^.pal[y].green);
		Obr.palette^.pal[y].blue:=not(Obr.palette^.pal[y].blue);
		end;
	exit;
	end;

  ldblk:=(longint(Obr.planes)*Obr.x+7) div 8;
  for y:= 0 to obr.Y-1 do
	begin
	if Obr.data^[y]<>nil then
		NotR(ldblk,Obr.data^[y]);

	if AlineProc<>nil then AlineProc^.NextLine;
	end;

end;


Procedure Histogram(var p:picture;var H:Phistogram);
var x,y:Word;
    ukRadek:^radekW;
    ukPixel:^Word;
begin
if not(p.Valid) then exit;
if p.planes>8 then exit;

if H=nil then new(H);
fillchar(H^,(1 shl p.planes)*4,0);

Getmem(ukRadek,2*P.x);
for y:=0 to p.y-1 do
  begin
  p.FormR(y,ukradek);
  ukPixel:=pointer(uKRadek);
  x:=p.x;
  while x>0 do
	begin
	inc(H^[ukPixel^]);
	inc(ukPixel);
	dec(x);
	end;
  end;
Freemem(ukRadek,2*P.x);{}
end;


Procedure Equalise(var EqObr:Picture;PercentLoss:byte);
type ttr=array[0..256] of word;
var hist:PHistogram;
    k:real;
    LowA,MaxA:Word;
    trtable:^ttr;
    ukRadek:^radekW;
    ukPixel:^Word;
    i,j:Word;

begin
 if not(EqObr.Valid) then exit;
 hist:=nil;
 Histogram(EqObr,hist);
 if hist=nil then exit;

 ErasePalette(EqObr.palette);
 new(trtable);
 GetMem(ukRadek,2*EqObr.x);{}

 k:=round(longint(EqObr.x)*PercentLoss*EqObr.y/(100*256));
 if k<1 then k:=1;
 lowA:=0;
 while hist^[lowA]<=k do
	begin
	trtable^[lowA]:=0;
	inc(lowA);
	if(lowA=0) then break; {counter overflow}
	end;
 maxA:=255;
 while hist^[maxA]<=k do
	begin
	trtable^[maxA]:=255;
	dec(maxA);
	if(maxA=255) then break; {counter underflow}
	end;
 trtable^[maxA]:=255;
 k:=255/(maxA-lowA);		{new use for k}
 for i:=0 to (maxA-lowA) do trtable^[i+lowA]:=trunc(k*i);

 for j:=0 to EqObr.y-1 do
	begin
	EqObr.FormR(j,ukradek);
	ukPixel:=pointer(uKRadek);
	for i:=0 to EqObr.x-1 do
		begin
		ukPixel^:=trtable^[ukPixel^];
		inc(ukPixel);
		end;

	EqObr.RfrmB(j,ukradek);
	end;

 if hist<>nil then dispose(hist);
 if trtable<>nil then dispose(trtable);
 Freemem(ukRadek,2*EqObr.x);{}
end;


Procedure Convert(var srP:Picture;var destP:picture;DestPlanes:byte;DestTyp:char;scale:Boolean;
		  AlineProc:PAbstractLineProc);
var i:Word;
    Formater:PFormStruct;
label KONEC;
begin
 DestP.Erase;		{zruseni predchozich dat}
 if not(SrP.Valid) then exit;

 if destPlanes in [1,2,4,8,16,24,32] then destP.planes:=destPlanes;
 DestP.Create(srp.x,srp.y,destPlanes);
 if not(DestP.Valid) then exit;

 i:=0;
 if not(Scale) then i:=i or NoScale;
 Formater:=InitFormatter(srp.x, Srp.typ, Srp.Planes,
				DestTyp, DestPlanes, i);
 if(Formater=nil) then exit; {cannot be converted}
 if Srp.typ='P' then Formater^.Palette:=addr(Srp.Palette^.pal[0]);


 for i:=0 to DestP.y-1 do
	begin
	Formater^.conv(Formater,Srp.Data^[i],Destp.Data^[i]);

	if AlineProc<>nil then AlineProc^.NextLine;
	end;

 Dispose(Formater);
end;

Procedure Separate(var srP:Picture;var destP:picture;color:char;AlineProc:PAbstractLineProc);
var i,j:Word;
    k0,k1,k2:byte;
    ColSep:byte;
    TempData,T2RGB:^RGB;
    P1b:^byte;
    Formater:PFormStruct;
label KONEC;
begin
 DestP.Erase;		{zruseni predchozich dat}
 if not(SrP.Valid) then exit;

 DestP.Create(srp.x,srp.y,8);
 if not(DestP.Valid) then exit;
 CreatePalette(DestP.Palette,DestP.Planes);

 getmem(TempData,3*srp.x);
 Formater:=InitFormatter(srp.x, Srp.typ, Srp.Planes,
				'C',     24,        0);
 if(Formater=nil) then exit; {cannot be converted}
 if Srp.typ='P' then Formater^.Palette:=addr(Srp.Palette^.pal[0]);

 case color of
	'R':begin
	    ColSep:=0;
	    for i:=0 to DestP.palette^.colors-1 do
		begin
		DestP.palette^.pal[i].green:=0;
		DestP.palette^.pal[i].blue:=0;
		end;
	    end;
	'G':begin
	    ColSep:=1;
	    for i:=0 to DestP.palette^.colors-1 do
		begin
		DestP.palette^.pal[i].red:=0;
		DestP.palette^.pal[i].blue:=0;
		end;
	    end;
	'B':begin
	    ColSep:=2;
	    for i:=0 to DestP.palette^.colors-1 do
		begin
		DestP.palette^.pal[i].red:=0;
		DestP.palette^.pal[i].green:=0;
		end;
	    end;
	'J':begin
	    ColSep:=$10;
	    k0:=1;k1:=1;k2:=0;
	    for i:=0 to DestP.palette^.colors-1 do
		begin
		DestP.palette^.pal[i].blue:=0;
		end;
	    end;
	'C':begin
	    ColSep:=$10;
	    k0:=0;k1:=1;k2:=1;
	    for i:=0 to DestP.palette^.colors-1 do
		begin
		DestP.palette^.pal[i].red:=0;
		end;
	    end;
	'M':begin
	    ColSep:=$10;
	    k0:=1;k1:=0;k2:=1;
	    for i:=0 to DestP.palette^.colors-1 do
		begin
		DestP.palette^.pal[i].green:=0;
		end;
	    end;
       else exit;
    end;

 if ColSep<$10
     then begin
	  for i:=0 to DestP.y-1 do
	       begin
	       Formater^.conv(Formater,Srp.Data^[i],TempData);
	       Separate_R(Srp.x,ColSep,TempData,Destp.Data^[i]);

	       if AlineProc<>nil then AlineProc^.NextLine;
	       end;
	 end
    else begin
	 for i:=0 to DestP.y-1 do
	       begin
	       Formater^.conv(Formater,Srp.Data^[i],TempData);
	       p1b:=addr(Destp.Data^[i]^.b[0]);
	       T2RGB:=TempData;
	       for j:=0 to DestP.x-1 do
			begin
			p1b^:=(k0*T2RGB^.Red+k1*T2RGB^.Green+k2*T2RGB^.Blue) div 2;
			inc(p1b);
			inc(T2RGB);
			end;
	       if AlineProc<>nil then AlineProc^.NextLine;
	       end;
	 end;

 freemem(TempData,3*srp.x);
 Dispose(Formater);
end;



Procedure FormR(var p:AbstractPicture;i:Word;Data:Pointer);
begin
 p.FormR(i,Data);
end;


Procedure Operation1(var Obr:Picture;Operation:func1;ukParameters:Pointer;AlineProc:PAbstractLineProc);
var i,j:word;
    P1:^Word;
begin
if (obr.Data=nil) then exit;
GetMem(P1,Obr.x*Sizeof(Word));
for j:=0 to obr.Y-1 do
	begin
	Obr.FormR(j,P1);
	Operation(P1,Obr.X,ukParameters);
	RfrmB(Obr,j,P1);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

FreeMem(P1,Obr.x*Sizeof(Word));
end;


Procedure Operation2(var obr1,obr2:picture;Operation:func2;Param:Pointer;AlineProc:PAbstractLineProc);
var i,j:word;
    P1,P2:^Word;
    MaxX:Word;
begin
if (obr1.Data=nil)or(obr2.Data=nil) then exit;
MaxX:=Obr1.x;
GetMem(P1,MaxX*Sizeof(Word));
GetMem(P2,MaxX*Sizeof(Word));
for j:=0 to obr1.Y-1 do
	begin
	Obr1.FormR(j,P1);
	Obr2.FormR(j,P2);
	Operation(P1,P2,Obr1.X,Param);
	RfrmB(Obr1,j,P1);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;

FreeMem(P2,MaxX*Sizeof(Word));
FreeMem(P1,MaxX*Sizeof(Word));
end;


Procedure BinarOperation2(var Obr1,Obr2:Picture;Operation:BinarFunc2;AlineProc:PAbstractLineProc);
var i,ldblk:word;
begin
if ((obr1.Data=nil)or(obr2.Data=nil))or((Obr1.planes<>1)or(obr2.planes<>1)) then exit;
ldblk:=(Obr1.x+7) div 8;
for i:=0 to Obr1.y-1 do
	begin
	Operation(ldblk,Obr1.data^[i],Obr2.data^[i]);
	if AlineProc<>nil then AlineProc^.NextLine;
	end;
end;


{$ifdef graph}
Procedure picture.view(AlineProc:PAbstractLineProc);
var i,j,n:word;
    maxGY,maxGX:Word;
    ukRadekX:^byte;
    ukRadekX2:^byte;
    ukPixel:^Word;ukPixelB:^Byte absolute ukpixel;
    DispPlanes:Byte;

    ConvStruct:BasicFormStruct;
    PoSun:Word;
    NewPalette:PPalette;
    color:RGB;

Label Konec;
begin
if data=nil then exit;
NewPalette:=nil;
if OffsetX<0 then OffsetX:=0;
if OffsetY<0 then OffsetY:=0;

i:=planes;
DispPlanes:=round(ln(GetMaxColor)/ln(2));
if i>DispPlanes then i:=DispPlanes;


if SetPalette and (DispPlanes<>24) then
  begin
  CreatePalette(NewPalette,i);

  if (NewPalette<>nil) then
	begin
	if (Palette<>nil) then
		move(palette^.pal,NewPalette^.pal,min(NewPalette^.Colors,palette^.Colors)*Sizeof(RGB))
		else if planes=24 then FormTCPalette(NewPalette);


	for I:=$0 to NewPalette^.Colors-1 do
		begin
		NewPalette^.pal[I].red:=NewPalette^.pal[I].red shr 2;
		NewPalette^.pal[I].green:=NewPalette^.pal[I].green shr 2;
		NewPalette^.pal[I].blue:=NewPalette^.pal[I].blue shr 2;
		end;

{$ifdef fgraph} SetRGBBlock(0,NewPalette^.Colors,NewPalette^.pal);
{$else}   for i:=0 to NewPalette^.Colors-1 do
	      SetRGBPalette(I,NewPalette^.pal[I].red,NewPalette^.pal[I].green,NewPalette^.pal[I].blue);
{$endif}
	end;
  ErasePalette(NewPalette);
  end;

 maxGY:=min(GetMaxY,Y-offsetY);
 maxGX:=min(GetMaxX,X-offsetX);

 ConvStruct.Items:=MaxGX+offsetX;
 ConvStruct.SrcTyp:=Typ;
 if palette<>nil then ConvStruct.Palette:=addr(palette^.pal);
 if (Typ='P')and((DispPlanes<>24)or(palette=nil)) then
					ConvStruct.SrcTyp:='G';
 ConvStruct.SrcPlanes:=planes;
 ConvStruct.DestTyp:='G';
 if (DispPlanes=24)or(Typ='C') then ConvStruct.DestTyp:='C';
 ConvStruct.DestPlanes:=DispPlanes;
 if ConvStruct.DestPlanes<8 then ConvStruct.DestPlanes:=8;
 if((ConvStruct.DestPlanes>=ConvStruct.SrcPlanes) or (ConvStruct.SrcTyp<>'G')) then
   ConvStruct.Options:=NoScale
 else
   ConvStruct.Options:=0;

 Getmem(ukRadekX,(ConvStruct.DestPlanes shr 3)*(maxGX+offsetX));
 ukRadekX2:=pointer(ukRadekX);
 inc(ukRadekX2,(ConvStruct.DestPlanes shr 3)*offsetX);

{$ifdef Fgraph}
 for j:=OffsetY to MaxGY-1+OffsetY do
    begin
    C_XX_YY(@ConvStruct,data^[j],UkRadekX);

    Bitmap(0,j-OffsetY,MaxGX-1,1,ukradekX2);

    if AlineProc<>nil then if AlineProc^.NextLine<0 then goto Konec;  {Dialog s uzivatelem}
    end;

{$else}
for j:=OffsetY to MaxGY-1+OffsetY do
    begin
    FormR(j,ukradekX);
    ukradekX2:=pointer(uKRadekX);
    inc(ukPixel,OffsetX);

    if planes=1 then
		begin
		for i:=0 to MaxGX-1 do
		  if pixel(self,j,i)>=1 then PutPixel(i,j-OffsetY,1)
		end
	else  for i:=0 to MaxGX-1 do
	begin

	if ukPixel^>51 then PutPixel(2*i,2*(j-OffsetY),1);
	if ukPixel^>102 then PutPixel(2*i+1,2*(j-OffsetY),1);
	if ukPixel^>153 then PutPixel(2*i+1,2*(j-OffsetY)+1,1);
	if ukPixel^>204 then PutPixel(2*i,2*(j-OffsetY)+1,1);

{       PutPixel(i,j-OffsetY,Mez^[ukPixel^]);  }
	inc(UkPixel);
	end;
    if AlineProc<>nil then if AlineProc^.NextLine<0 then goto Konec; {Dialog s uzivatelem}
    end;

{$endif}
Konec:
Freemem(ukRadekX,(ConvStruct.DestPlanes shr 3)*(maxGX+offsetX));{}
end;
{$endif}



Procedure ClearPixel(var p:picture;x,y:integer);
var b:byte;
begin
 SetPixel(p,x,y,0);
end;


Procedure Peel1plane(var p:picture;y:word;plane:byte;ukbity:pointer);
var blen:word;
    pq:pointer;
    ukradek:^word;

begin
ukradek:=nil;

blen:=(p.x+7) shr 3;
fillchar(ukbity^,blen,0);
if (plane>p.planes)or(y>=p.y) then exit;

pq:=p.data^[y];

case p.planes of
   1:move(pq^,ukbity^,blen);
   8:peelX(p.x,pq,ukbity,1 shl (plane-1),1);
  24:begin
     while plane>8 do
		begin
		inc(longint(pq));
		dec(plane,8);
		end;
     peelX(p.x,pq,ukbity,1 shl (plane-1),3);
     end;
  32:begin
     while plane>8 do
		begin
		inc(longint(pq));
		dec(plane,8);
		end;
     peelX(p.x,pq,ukbity,1 shl (plane-1),4);
     end;
   else begin		{also 16}
	if p.planes<>16 then
		begin
		getmem(ukradek,2*p.x);
		p.FormR(y,ukradek);
		pq:=ukradek;
		end;
	if plane>8 then
		begin
		inc(longint(pq));
		dec(plane,8);
		end;
	peelX(p.x,pq,ukbity,1 shl (plane-1),2);

	if ukradek<>nil then Freemem(ukradek,2*p.x);
	end;
    end;
end;

Procedure PeelPlane(var obr:Picture;var PlaneX:Picture;PlaneNum:Byte);
var y:Word;
begin
PlaneX.Erase;
if ((PlaneNum<=0)or(PlaneNum>Obr.Planes))or(not(Obr.Valid)) then exit;
PlaneX.Create(Obr.x,Obr.y,1 or NoFill);

for y:=0 to Obr.y-1 do		{hlavni radkova smycka}
       begin
       Peel1Plane(obr,y,planeNum,pointer(planex.data^[y]));
       end;
end;


Procedure Join1plane(var p:picture;y:word;plane:byte;ukbity:pointer);
var blen:word;
    pq:pointer;
    ukradek:^word;

begin
ukradek:=nil;

blen:=(p.x+7) shr 3;
if (plane>p.planes)or(y>=p.y) then exit;

pq:=p.data^[y];

case p.planes of
   1:move(ukbity^,pq^,blen);
   8:JoinX(p.x,pq,ukbity,1 shl (plane-1),1);
  24:begin
     while plane>8 do
		begin
		inc(longint(pq));
		dec(plane,8);
		end;
     JoinX(p.x,pq,ukbity,1 shl (plane-1),3);
     end;
  32:begin
     while plane>8 do
		begin
		inc(longint(pq));
		dec(plane,8);
		end;
     JoinX(p.x,pq,ukbity,1 shl (plane-1),4);
     end;
   else begin		{also 16}
	if p.planes<>16 then
		begin
		getmem(ukradek,2*p.x);
		p.FormR(y,ukradek);
		pq:=ukradek;
		end;
	if plane>8 then
		begin
		inc(longint(pq));
		dec(plane,8);
		end;
	JoinX(p.x,pq,ukbity,1 shl (plane-1),2);

	if ukradek<>nil then
		begin
		p.Rfrmb(y,ukradek);
		Freemem(ukradek,2*p.x);
		end;
	end;
    end;
end;


Procedure JoinPlane(var PlaneX:Picture;var obr:Picture;PlaneNum:Byte);
var y,MaxY:Word;
begin
if ((PlaneNum<=0)or(PlaneNum>Obr.Planes))or(not(PlaneX.Valid)) then exit;
if not(Obr.Valid) then
	begin;
	Obr.Create(PlaneX.x,PlaneX.y,PlaneNum);
	if not(Obr.Valid) then exit;
	end;

maxY:=min(Obr.y,planeX.y)-1;
for y:=0 to MaxY do		{hlavni radkova smycka}
	begin
	Join1Plane(obr,y,planeNum,pointer(planex.data^[y]));
	end;

end;


Procedure Thr(var Obr:AbstractPicture;var ph:Picture;h:integer;AlineProc:PAbstractLineProc);
var i,j:integer;
    p,p2:pointer;
    xm:word;
begin
if not(Obr.Valid) then exit;
ph.Create(Obr.x,Obr.y,1);
GetMem(p,2*Obr.X);
xm:=Obr.x;
for i:=0 to Obr.y-1 do
  begin
  Obr.FormR(i,p);                 {!!!>=!!!}
  p2:=Ph.data^[i];
  asm
        push	ds
	push	es

        lds	SI,p
        les	DI,p2
        mov	CX,xm
	mov	BL,$80
@LoopX: LODSW
        cmp	ax,h
	jl	@NoSet
        or	byte ptr ES:DI,bl

@NoSet: ror	bl,1
        jnc	@NoInc
	inc	DI
@NoInc: LOOP	@LoopX

        pop	es
	pop	ds
	end;
  if AlineProc<>nil then AlineProc^.NextLine;
  end;
FreeMem(p,2*Obr.X);
(*for j:=0 to Obr.x-1 do for i:=0 to Obr.y-1 do	if pixel(Obr,i,j)>=h then setpixel(ph,i,j,1);(**)
end;


Procedure Floyd(var Obr:AbstractPicture;var ph:Picture;h:integer;AlineProc:PAbstractLineProc);
var i,j:integer;
    p,p2,np,np2:^integer;
    zbytek:integer;
begin
if not(Obr.Valid) then exit;
ph.Create(Obr.x,Obr.y,1);
GetMem(p,2*(Obr.X+1));
GetMem(np,2*(Obr.X+1));

fillchar(np^,2*(Obr.X+1),0);
for i:=0 to Obr.y-1 do
  begin
  Obr.FormR(i,p);                 {!!!>=!!!}
  p2:=p;
  np2:=np;

  for j:=0 to Obr.x-1 do
	begin
	p2^:=p2^+np2^;
	inc(p2);
	inc(np2);
	end;

  p2:=p;
  np2:=np;
  np2^:=0;
  zbytek:=0;

  for j:=0 to Obr.x-1 do
	begin
	p2^:=p2^+zbytek;
	if p2^>h then
		begin
		SetPixel(ph,j,i,1);
		zbytek:=p2^-255;
		end
		else zbytek:=p2^;

	np2^:=zbytek*3 div 8;
	inc(np2);
	np2^:=zbytek*1 div 4;
	zbytek:=zbytek*3 div 8;

	inc(p2);
	end;
  if AlineProc<>nil then AlineProc^.NextLine;
  end;
FreeMem(p,2*Obr.X);
FreeMem(np,2*Obr.X);

(*for j:=0 to Obr.x-1 do for i:=0 to Obr.y-1 do	if pixel(Obr,i,j)>=h then setpixel(ph,i,j,1);(**)
end;


Procedure AndR(maxX:Word;R1,R2:Pointer); assembler; {R1:=R1 and R2}
asm
	push	es
        push	ds
        cld
        mov	cx,maxX
        mov	bl,cl
        les	di,R1
        lds	si,R2

{$ifopt g+}
        shr	cx,2		{poced dwordu}
	jcxz	@endD
@loop:db 66h;lodsw			{smycka pro dwordy}
db 66h;	and	ax,word ptr ES:DI
db 66h;	stosw
        loop	@Loop
@endD:  test	bl,2
	jz	@endW
        lodsw			{zbyly word}
	and	ax,word ptr ES:DI
	stosw

{$else} shr	cx,1		{poced wordu}
	jcxz	@endW
@loop:	lodsw			{smycka pro wordy}
	and	ax,word ptr ES:DI
	stosw
        loop	@Loop
{$endif}
@endW:  test	bl,1
	jz	@end
	lodsb			{zbyly byte}
	and	al,byte ptr ES:DI
	stosb
@end:	pop	ds
        pop	es
end;


Procedure OrR(maxX:Word;R1,R2:Pointer); assembler; {R1:=R1 or R2}
asm
	push	es
        push	ds
        cld
        mov	cx,maxX
        mov	bl,cl
        les	di,R1
        lds	si,R2

{$ifopt g+}
        shr	cx,2		{poced dwordu}
	jcxz	@endD
@loop:db 66h;lodsw			{smycka pro dwordy}
db 66h;	or	ax,word ptr ES:DI
db 66h;	stosw
        loop	@Loop
@endD:  test	bl,2
	jz	@endW
        lodsw			{zbyly word}
	or	ax,word ptr ES:DI
	stosw

{$else} shr	cx,1		{poced wordu}
	jcxz	@endW
@loop:	lodsw			{smycka pro wordy}
	or	ax,word ptr ES:DI
	stosw
        loop	@Loop
{$endif}
@endW:  test	bl,1
	jz	@end
	lodsb			{zbyly byte}
	or	al,byte ptr ES:DI
	stosb
@end:	pop	ds
        pop	es
end;


Procedure XorR(maxX:Word;R1,R2:Pointer); assembler; {R1:=R1 xor R2}
asm
	push	es
        push	ds
        cld
        mov	cx,maxX
        mov	bl,cl
        les	di,R1
        lds	si,R2

{$ifopt g+}
        shr	cx,2		{poced dwordu}
	jcxz	@endD
@loop:db 66h;lodsw			{smycka pro dwordy}
db 66h;	xor	ax,word ptr ES:DI
db 66h;	stosw
        loop	@Loop
@endD:  test	bl,2
	jz	@endW
        lodsw			{zbyly word}
	xor	ax,word ptr ES:DI
	stosw

{$else} shr	cx,1		{poced wordu}
	jcxz	@endW
@loop:	lodsw			{smycka pro wordy}
	xor	ax,word ptr ES:DI
	stosw
        loop	@Loop
{$endif}
@endW:  test	bl,1
	jz	@end
	lodsb			{zbyly byte}
	xor	al,byte ptr ES:DI
	stosb
@end:	pop	ds
        pop	es
end;


Procedure NotR(maxX:Word;R:Pointer); assembler;	{R1:=not(R1)}
asm
	push	ds
	mov	cx,maxX
	jcxz	@end
	lds	si,R
@loop:	not	byte ptr DS:SI
	inc	si
	loop	@Loop
@end:	pop	ds
end;


Procedure Shr_R(maxX:Word;R:Pointer); assembler;	{R1:=R1 shr 1}
asm
        push	ds
        mov	cx,maxX
	jcxz	@end
        lds	si,R
        mov	al,byte ptr DS:SI
        shl	al,1
@loop:	rcr	byte ptr DS:SI,1
	inc	si
        loop	@Loop
@end:	pop	ds
end;


Procedure Shl_R(maxX:Word;R:Pointer;zbytek:Byte); assembler; {R1:=R1 shl 1}
asm
        push	ds
        mov	cx,maxX
	jcxz	@end
	lds	si,R
        add	si,cx
        dec	si
        mov	al,byte ptr DS:SI
	mov	bl,zbytek		{kopie posledniho bitu}
	shr	bl,1
        not	bl
	and	bl,al
        and	al,zbytek
        shr	al,1
        or	al,bl
        mov	byte ptr DS:SI,al
	shr	al,1
@loop:	rcl	byte ptr DS:SI,1
	dec	si
        loop	@Loop
@end:	pop	ds
end;


Procedure Dilatation(var Obr,ObrD:Picture;typ:Word;AlineProc:PAbstractLineProc);
var DelkaRadku:word;
    data,BufData:Pointer;
    newData:array[0..2]of Pointer;
    i,q1,q2,q3:integer;
    zbytek:byte;
begin
if not(Obr.Valid) then exit;
ObrD.Create(Obr.x,Obr.y,Obr.Planes);
if not(ObrD.Valid) then exit;
if AlineProc<>nil then
	AlineProc^.InitPassing(Obr.y,'Dilatating');

if Obr.planes=1 then		{2-urovnovy}
	begin
	DelkaRadku:=(Obr.x+7) div 8;	

	GetMem(Data,DelkaRadku);
	GetMem(NewData[0],DelkaRadku);
	GetMem(NewData[1],DelkaRadku);
	GetMem(NewData[2],DelkaRadku);

	zbytek:=1 shl (7-((Obr.x+7) mod 8));
	BufData:=Obr.Data^[0];	{zpracovani 0. radku}
	for i:=-1 to Obr.y do	{hlavni smycka}
	 begin
	 if (i>0)and(i<Obr.y) then BufData:=Obr.Data^[i];{zpracovani dalsiho radku}

	 q3:=(i+4) mod 3;	{radek c.1}
	 q2:=(i+5) mod 3;	{radek c.2}
	 q1:=(i+6) mod 3;	{radek c.3}

	 fillchar(NewData[q1]^,DelkaRadku,$00);
	 if typ and   8=  8 then OrR(DelkaRadku,NewData[q1],Bufdata);
	 if typ and   1=  1 then OrR(DelkaRadku,NewData[q2],Bufdata);
	 if typ and 128=128 then OrR(DelkaRadku,NewData[q3],Bufdata);

	 move(BufData^,data^,DelkaRadku);
	 shl_R(delkaRadku,data,zbytek);
	 if typ and  16= 16 then OrR(DelkaRadku,NewData[q1],data);
	 if typ and  32= 32 then OrR(DelkaRadku,NewData[q2],data);
	 if typ and  64= 64 then OrR(DelkaRadku,NewData[q3],data);

	 move(BufData^,data^,DelkaRadku);
	 shr_R(DelkaRadku,data);
	 if typ and   4=  4 then OrR(DelkaRadku,NewData[q1],data);
	 if typ and   2=  2 then OrR(DelkaRadku,NewData[q2],data);
	 if typ and 256=256 then OrR(DelkaRadku,NewData[q3],data);

	 if i>0 then
	       begin
	       move(NewData[q3]^,obrD.data^[i-1]^,DelkaRadku);
	       if AlineProc<>nil then AlineProc^.NextLine;	 {Dialog s uzivatelem}
	       end;
	 end;
	 end

     else begin			{sedotonovy}
	  DelkaRadku:=2*Obr.X;

	  GetMem(BufData,DelkaRadku);
	  GetMem(Data,DelkaRadku);
	  GetMem(NewData[0],DelkaRadku);
	  GetMem(NewData[1],DelkaRadku);
	  GetMem(NewData[2],DelkaRadku);

	  Obr.FormR(0,BufData);		{zpracovani 0. radku}
	  for i:=-1 to Obr.y do	{hlavni smycka}
	   begin
	   if (i>0)and(i<Obr.y) then
		Obr.FormR(i,BufData);{zpracovani dalsiho radku}

	   q3:=(i+4) mod 3;	{radek c.1}
	   q2:=(i+5) mod 3;	{radek c.2}
	   q1:=(i+6) mod 3;	{radek c.3}

	   fillchar(NewData[q1]^,DelkaRadku,$00);
	   if typ and   8=  8 then MaxW(Obr.x,NewData[q1],Bufdata);
	   if typ and   1=  1 then MaxW(Obr.x,NewData[q2],Bufdata);
	   if typ and 128=128 then MaxW(Obr.x,NewData[q3],Bufdata);

	   move(BufData^,data^,DelkaRadku);
	   ShRW(obr.x,data,nil);
	   if typ and  16= 16 then MaxW(Obr.x,NewData[q1],data);
	   if typ and  32= 32 then MaxW(Obr.x,NewData[q2],data);
	   if typ and  64= 64 then MaxW(Obr.x,NewData[q3],data);

	   move(BufData^,data^,DelkaRadku);
	   ShLW(obr.x,data,nil);
	   if typ and   4=  4 then MaxW(Obr.x,NewData[q1],data);
	   if typ and   2=  2 then MaxW(Obr.x,NewData[q2],data);
	   if typ and 256=256 then MaxW(Obr.x,NewData[q3],data);

	   if i>0 then
		 begin
		 obrD.RfrmB(i-1,NewData[q3]);
		 if AlineProc<>nil then AlineProc^.NextLine;	 {Dialog s uzivatelem}
		 end;
	   end;

	  FreeMem(BufData,DelkaRadku);
	  end;

	      {vse zatim probehlo OK}
FreeMem(Data,DelkaRadku);
FreeMem(NewData[0],DelkaRadku);
FreeMem(NewData[1],DelkaRadku);
FreeMem(NewData[2],DelkaRadku);
end;


Procedure Erosion(var Obr,ObrD:Picture;typ:Word;AlineProc:PAbstractLineProc);
var DelkaRadku:word;
    data,BufData:Pointer;
    newData:array[0..2]of Pointer;
    i,q1,q2,q3:integer;
    zbytek:byte;
begin
if not(Obr.Valid) then exit;
ObrD.Create(Obr.x,Obr.y,Obr.planes);
if not(ObrD.Valid) then exit;
if AlineProc<>nil then
	AlineProc^.InitPassing(Obr.y,'Erosing');


if Obr.planes=1 then		{2-urovnovy}
	begin
	DelkaRadku:=(Obr.x+7) div 8;

	GetMem(Data,DelkaRadku);
	GetMem(NewData[0],DelkaRadku);
	GetMem(NewData[1],DelkaRadku);
	GetMem(NewData[2],DelkaRadku);

	zbytek:=1 shl (7-((Obr.x+7) mod 8));


	BufData:=Obr.Data^[0];	{zpracovani 0. radku}
	for i:=-1 to Obr.y do	{hlavni smycka}
	  begin
	  if (i>0)and(i<Obr.y) then BufData:=Obr.Data^[i];{zpracovani dalsiho radku}

	  q3:=(i+4) mod 3;	{radek c.1}
	  q2:=(i+5) mod 3;	{radek c.2}
	  q1:=(i+6) mod 3;	{radek c.3}

	  fillchar(NewData[q1]^,DelkaRadku,$FF);
	  if typ and   8=  8 then AndR(DelkaRadku,NewData[q1],Bufdata);
	  if typ and   1=  1 then AndR(DelkaRadku,NewData[q2],Bufdata);
	  if typ and 128=128 then AndR(DelkaRadku,NewData[q3],Bufdata);

	  move(BufData^,data^,DelkaRadku);
	  shl_R(delkaRadku,data,zbytek);
	  if typ and  16= 16 then AndR(DelkaRadku,NewData[q1],data);
	  if typ and  32= 32 then AndR(DelkaRadku,NewData[q2],data);
	  if typ and  64= 64 then AndR(DelkaRadku,NewData[q3],data);

	  move(BufData^,data^,DelkaRadku);
	  shr_R(DelkaRadku,data);
	  if typ and   4=  4 then AndR(DelkaRadku,NewData[q1],data);
	  if typ and   2=  2 then AndR(DelkaRadku,NewData[q2],data);
	  if typ and 256=256 then AndR(DelkaRadku,NewData[q3],data);

	  if i>0 then
		begin
		move(NewData[q3]^,obrD.data^[i-1]^,DelkaRadku);
		if AlineProc<>nil then AlineProc^.NextLine;	 {Dialog s uzivatelem}
		end;
	  end;
	end
      else begin			{sedotonovy}
	  DelkaRadku:=2*Obr.X;

	  GetMem(BufData,DelkaRadku);
	  GetMem(Data,DelkaRadku);
	  GetMem(NewData[0],DelkaRadku);
	  GetMem(NewData[1],DelkaRadku);
	  GetMem(NewData[2],DelkaRadku);

	  Obr.FormR(0,BufData);		{zpracovani 0. radku}
	  for i:=-1 to Obr.y do	{hlavni smycka}
	   begin
	   if (i>0)and(i<Obr.y) then
		Obr.FormR(i,BufData);{zpracovani dalsiho radku}

	   q3:=(i+4) mod 3;	{radek c.1}
	   q2:=(i+5) mod 3;	{radek c.2}
	   q1:=(i+6) mod 3;	{radek c.3}

	   fillchar(NewData[q1]^,DelkaRadku,$FF);
	   if typ and   8=  8 then MinW(Obr.x,NewData[q1],Bufdata);
	   if typ and   1=  1 then MinW(Obr.x,NewData[q2],Bufdata);
	   if typ and 128=128 then MinW(Obr.x,NewData[q3],Bufdata);

	   move(BufData^,data^,DelkaRadku);
	   ShRW(obr.x,data,nil);
	   if typ and  16= 16 then MinW(Obr.x,NewData[q1],data);
	   if typ and  32= 32 then MinW(Obr.x,NewData[q2],data);
	   if typ and  64= 64 then MinW(Obr.x,NewData[q3],data);

	   move(BufData^,data^,DelkaRadku);
	   ShLW(obr.x,data,nil);
	   if typ and   4=  4 then MinW(Obr.x,NewData[q1],data);
	   if typ and   2=  2 then MinW(Obr.x,NewData[q2],data);
	   if typ and 256=256 then MinW(Obr.x,NewData[q3],data);

	   if i>0 then
		 begin
		 obrD.RfrmB(i-1,NewData[q3]);
		 if AlineProc<>nil then AlineProc^.NextLine;	 {Dialog s uzivatelem}
		 end;
	   end;

	  FreeMem(BufData,DelkaRadku);
	  end;
	       {vse zatim probehlo OK}
FreeMem(Data,DelkaRadku);
FreeMem(NewData[0],DelkaRadku);
FreeMem(NewData[1],DelkaRadku);
FreeMem(NewData[2],DelkaRadku);
end;


Procedure HitOrMiss(var Obr,ObrD:Picture;El:Telement;AlineProc:PAbstractLineProc);
var DelkaRadku:word;
    data,BufData:Pointer;
    newDataFg,newDataBk:array[0..2]of ^byte;
    i,q1,q2,q3:integer;
    e:byte;
    zbytek:byte;
begin
if not(Obr.valid) or (Obr.planes<>1) then exit;
ObrD.Create(Obr.x,Obr.y,1);
if not(ObrD.Valid) then exit;

DelkaRadku:=(Obr.x+7) div 8;	{2-urovnovy}
zbytek:=1 shl (7-((Obr.x+7) mod 8));

GetMem(Data,DelkaRadku);
GetMem(NewDataFg[0],DelkaRadku);
GetMem(NewDataFg[1],DelkaRadku);
GetMem(NewDataFg[2],DelkaRadku);
GetMem(NewDataBk[0],DelkaRadku);
GetMem(NewDataBk[1],DelkaRadku);
GetMem(NewDataBk[2],DelkaRadku);

BufData:=Obr.Data^[0];	{zpracovani 0. radku}
for i:=-1 to Obr.y do	{hlavni smycka}
  begin
  if (i>0)and(i<Obr.y) then BufData:=Obr.Data^[i];{zpracovani dalsiho radku}

  q3:=(i+4) mod 3;	{radek c.1}
  q2:=(i+5) mod 3;	{radek c.2}
  q1:=(i+6) mod 3;	{radek c.3}

  fillchar(NewDataFg[q1]^,DelkaRadku,$FF);
  fillchar(NewDataBk[q1]^,DelkaRadku,$00);

  if El.Fg and   8=  8 then AndR(DelkaRadku,NewDataFg[q1],Bufdata);
  if El.Fg and   1=  1 then AndR(DelkaRadku,NewDataFg[q2],Bufdata);
  if El.Fg and 128=128 then AndR(DelkaRadku,NewDataFg[q3],Bufdata);
  if El.Bk and   8=  8 then OrR(DelkaRadku,NewDataBk[q1],Bufdata);
  if El.Bk and   1=  1 then OrR(DelkaRadku,NewDataBk[q2],Bufdata);
  if El.Bk and 128=128 then OrR(DelkaRadku,NewDataBk[q3],Bufdata);

  move(BufData^,data^,DelkaRadku);
  shl_R(delkaRadku,data,zbytek);
  if El.Fg and  16= 16 then AndR(DelkaRadku,NewDataFg[q1],data);
  if El.Fg and  32= 32 then AndR(DelkaRadku,NewDataFg[q2],data);
  if El.Fg and  64= 64 then AndR(DelkaRadku,NewDataFg[q3],data);
  if El.Bk and  16= 16 then OrR(DelkaRadku,NewDataBk[q1],data);
  if El.Bk and  32= 32 then OrR(DelkaRadku,NewDataBk[q2],data);
  if El.Bk and  64= 64 then OrR(DelkaRadku,NewDataBk[q3],data);

  move(BufData^,data^,DelkaRadku);
  shr_R(DelkaRadku,data);
  if El.Fg and   4=  4 then AndR(DelkaRadku,NewDataFg[q1],data);
  if El.Fg and   2=  2 then AndR(DelkaRadku,NewDataFg[q2],data);
  if El.Fg and 256=256 then AndR(DelkaRadku,NewDataFg[q3],data);
  if El.Bk and   4=  4 then OrR(DelkaRadku,NewDataBk[q1],data);
  if El.Bk and   2=  2 then OrR(DelkaRadku,NewDataBk[q2],data);
  if El.Bk and 256=256 then OrR(DelkaRadku,NewDataBk[q3],data);

  if i>0 then
  	begin
	NotR(DelkaRadku,NewDataBk[q3]);
	AndR(DelkaRadku,NewDataFg[q3],NewDataBk[q3]);
	move(NewDataFg[q3]^,obrD.data^[i-1]^,DelkaRadku);

	if AlineProc<>nil then AlineProc^.NextLine;	 {Dialog s uzivatelem}
	end;
  end;
	      {vse zatim probehlo OK}
FreeMem(Data,DelkaRadku);
FreeMem(NewDataFg[0],DelkaRadku);
FreeMem(NewDataFg[1],DelkaRadku);
FreeMem(NewDataFg[2],DelkaRadku);
FreeMem(NewDataBk[0],DelkaRadku);
FreeMem(NewDataBk[1],DelkaRadku);
FreeMem(NewDataBk[2],DelkaRadku);

end;


Procedure SeqThin(var Obr,ObrZ:Picture;El:Selement);
var DelkaRadku,i:Word;
    x:Byte;
    TempP:Picture;
begin
if not(Obr.valid) or (Obr.planes<>1) then exit;
TempP.Init;
MovePicture(Obr,ObrZ,nil);

DelkaRadku:=(Obr.x+7) div 8;	{2-urovnovy}

for x:=0 to El.Items-1 do
   begin
   HitOrMiss(ObrZ,TempP,El.E[x],nil);

   for i:=0 to Obr.y-1 do	{hlavni smycka}
	begin
	NotR(DelkaRadku,TempP.data^[i]);
	AndR(DelkaRadku,ObrZ.data^[i],TempP.Data^[i]);
	end;
   end;

TempP.Done;
end;


Procedure Thin1Step(var Obr,ObrZ:Picture;El:Telement);
var DelkaRadku,i:Word;
begin
 HitOrMiss(Obr,ObrZ,El,nil);

 DelkaRadku:=(Obr.x+7) div 8;	{2-urovnovy}

 for i:=0 to Obr.y-1 do	{hlavni smycka}
  begin
  NotR(DelkaRadku,ObrZ.data^[i]);
  AndR(DelkaRadku,ObrZ.data^[i],Obr.Data^[i]);
  end;

end;


Procedure SectiLw(maxX:Word;ukradek:PRadek;ukradekW:PRadekW); assembler;
asm
	PUSH	ES
	PUSH	DS
	CLD		{auto increment}
	MOV	CX,word ptr maxX
	LES	DI,ukRadek
	LDS	SI,ukRadekW
@@Loop: LODSW
	ADD	word ptr ES:DI,AX
        ADC	word ptr ES:[DI+2],0
@1:     ADD	DI,4
	LOOP	@@Loop

	POP	DS
	POP	ES
end;


Procedure OdectiLw(maxX:Word;ukradek:PRadek;ukradekW:PRadekW); assembler;
asm
	PUSH	ES
	PUSH	DS
	CLD		{auto increment}
	MOV	CX,word ptr maxX
	LES	DI,ukRadek
	LDS	SI,ukRadekW
@@Loop: LODSW
	SUB	word ptr ES:DI,AX
        SBB	word ptr ES:[DI+2],0
@1:     ADD	DI,4
	LOOP	@@Loop

	POP	DS
	POP	ES
end;


Function Compare(var obr1,obr2:picture;AlineProc:PAbstractLineProc):longint;
var y,i:word;
    Pl1,Pl2,P1,P2:^Word;
    Plb1: ^byte absolute Pl1;
    Plb2: ^byte absolute Pl2;
    Difference:Longint;
    ldblk:word;
    ConvS1,ConvS2:BasicFormStruct;
begin
Difference:=0;
Compare:=-1;

 if (obr1.Data=nil)or(obr2.Data=nil) then exit;
 if (obr1.x<>obr2.x)or(obr1.y<>obr2.y) then exit;

 if AlineProc<>nil then
	AlineProc^.InitPassing(Obr1.y,'Comparing 2 images');

 ConvS1.Items:=obr1.x;
 ConvS1.SrcTyp:=obr1.typ;
 ConvS1.SrcPlanes:=obr1.planes;
 ConvS1.DestTyp:='G';
 ConvS1.DestPlanes:=16;
 ConvS1.Options:=NoScale;

 ConvS2.Items:=obr2.x;
 ConvS2.SrcTyp:=obr2.typ;
 ConvS2.SrcPlanes:=obr2.planes;
 ConvS2.DestTyp:='G';
 ConvS2.DestPlanes:=16;
 ConvS2.Options:=NoScale;

 ldblk:=Obr1.X*Sizeof(Word);
 if ((obr1.typ='C')or(obr2.typ='C'))or((obr1.typ='P')or(obr2.typ='P')) then
	begin
	if obr1.typ='P' then ConvS1.Palette:=addr(Obr1.Palette^.pal);
	ConvS1.DestTyp:='C';
	ConvS1.DestPlanes:=24;
	if obr2.typ='P' then ConvS2.Palette:=addr(Obr2.Palette^.pal);
	ConvS2.DestTyp:='C';
	ConvS2.DestPlanes:=24;
	ldblk:=Obr1.X*3;
	end;

 GetMem(P1,ldblk);
 GetMem(P2,ldblk);

 for y:=0 to obr1.Y-1 do
	begin
	C_XX_YY(@ConvS1,obr1.data^[y],P1);
	C_XX_YY(@ConvS2,obr2.data^[y],P2);
	Pl1:=P1;Pl2:=P2;

	if ConvS2.DestTyp='C'
	   then
		begin
		for i:=0 to 3*obr1.X-1 do
			begin
			Difference:=Difference+abs(Plb1^-Plb2^);
			inc(Plb1);
			inc(Plb2);
			end;
		end
	   else
		begin
		for i:=0 to obr1.X-1 do
			begin
			Difference:=Difference+abs(Pl1^-Pl2^);
			inc(Pl1);
			inc(Pl2);
			end;
		end;

	if AlineProc<>nil then AlineProc^.NextLine;
	end;

FreeMem(P2,LdBlk);
FreeMem(P1,LdBlk);
Compare:=Difference;
end;


Procedure Mask(var Obr1:Picture;var Obr2:Picture;n:Word;AlineProc:PAbstractLineProc);
var k,k2:Word;
    i,j:Word;
    x,y:Word;
    y1,y2,x1,x2:integer;
    aLl:Longint;
    ukRadek:Pradek;
    ukRadekW:PradekW;
    Sptr,SptrAl,SptrAr:MyPtr;
    color,clr:byte;
Label 10;
begin
Obr2.Erase;
if (n=0)or(not(Obr1.Valid)) then exit;
Obr2.Create(Obr1.x,Obr1.y,Obr1.Planes);
if not(Obr2.Valid) then exit;

if AlineProc<>nil then
	AlineProc^.InitPassing(Obr1.y,'Filtering by MASK');

Getmem(ukRadek,4*Obr1.x);
Getmem(ukRadekW,2*Obr1.x);
k:=n*n;
k2:=k div 2;
x:=n div 2+1;
y:=n div 2+1;

color:=1;
if(Obr1.typ='C') and (Obr1.planes=24) then
  begin
  color:=3;
  Obr2.typ:='C';
  if AlineProc<>nil then AlineProc^.pases := AlineProc^.pases*3;
  end;

for clr:=0 to color-1 do
  begin

  y1:=x + 1;
  if n<=2 then dec(y1);		{pocet pridanych radek}

  fillchar(ukradek^,4*Obr1.x,0);
  if color=1 then
    Obr1.formR(0,ukradekW)
  else
    PeelB2W(Obr1.x,addr(Obr1.data^[0]^.b[clr]),ukradekW,3);

  for j:=1 to y1 do SectiLW(Obr1.x,ukradek,ukradekW); {ukradek=y1*ukradekW}


  for y1:=1 to integer(n+1)div 2 - 2 do
    begin 			{pridani pripravnych radku}
    if color=1 then
      Obr1.formR(y1,ukradekW)
    else
      PeelB2W(Obr1.x,addr(Obr1.data^[y1]^.b[clr]),ukradekW,3);
    SectiLW(Obr1.x,ukradek,ukradekW);
    end;

  for i:=0 to Obr1.y-1 do		{hlavni filtracni smycka}
    begin
    y1:=integer(i)-y;
    y2:=y1+n;
    if y1<0 then y1:=0;
    if y2>=Obr1.y then y2:=Obr1.y-1;

    if color=1 then
      Obr1.formR(y1,ukradekW)
    else
      PeelB2W(Obr1.x,addr(Obr1.data^[y1]^.b[clr]),ukradekW,3);
    OdectiLw(Obr1.x,ukradek,ukradekW);	{vyjmuti posledniho radku y1}

    if color=1 then
      Obr1.formR(y2,ukradekW)
    else
      PeelB2W(Obr1.x,addr(Obr1.data^[y2]^.b[clr]),ukradekW,3);
    SectiLw(Obr1.x,ukradek,ukradekW);	{pridani noveho radku y2}
				{zpracovani obsahu radku}
    x1:=y + 1;
    if n<=2 then dec(x1);		{pocet pridanych sloupcu}
    All:=x1*ukradek^[0];
    for x2:=1 to integer(n+1)div 2 - 2 do inc(All,ukradek^[x2]);

    Sptr.ptr:=ukRadekW;		{vypocet masky v radku}
    x1:=-integer(x);
    x2:=min(x1+n,Obr1.x-1);
    SptrAl.ptr:=ukradek;
    SptrAr.ptr:=ukradek; inc(SptrAr.ptrL,x2);
    for j:=0 to Obr1.x-1 do
      begin
      dec(All,SptrAl.ptrL^);
      inc(All,SptrAr.ptrL^);
  
      asm		{    Sptr.PtrW^:=(Al+k2) div k;}
	PUSH	ES
	MOV	AX,word ptr All
	MOV	DX,word ptr All+2
	ADD	AX,k2
	ADC	DX,0
	DIV	k
	LES	DI,sptr
	STOSW
	POP	ES
      end;

      if x1>=0 then       inc(SptrAl.ptrL);
      if x2<Obr1.x-1 then inc(SptrAr.ptrL);
      inc(Sptr.PtrW);
      inc(x1);
      inc(x2);
      end;
    
    if color=1 then
      RfrmB(Obr2,i,ukRadekW)	{ulozeni dat}
    else
      JoinW2B(Obr2.x,addr(Obr2.data^[y2]^.b[clr]),ukradekW,3);	{ulozeni dat}

    if AlineProc<>nil then AlineProc^.NextLine;	{Dialog s uzivatelem}
    end;
  end;

FreeMem(ukRadekW,2*Obr1.x);
FreeMem(ukRadek,4*Obr1.x);
end;


type PMed=^TMed;
     TMed=record
	   maxsz:word;
	   size:word;
	   data:array[0..8] of word;
	  end;

Procedure Zarad(n:word;w:PMed); assembler;
asm
	push	ds
	push	es
	std
	les	di,w
	mov	ax,es
	mov	ds,ax

	mov	cx,(TMed ptr es:[di]).size
	inc	cx
	cmp	(TMed ptr es:[di]).maxsz,cx
	jc	@Kon2                     {Kontrola max delky}
	mov	(TMed ptr es:[di]).size,cx
       { dec	cx}
	mov	ax,cx
	dec	ax
	shl	ax,1
        add	di,Tmed.Data
	add	di,ax

	mov	bx,Word ptr n
	mov	si,di
	sub	si,2
	JC	@Kon1

@Loop1:	cmp	bx,[si]
	JNB	@Kon1
	movsw
	LOOP	@Loop1
	add	di,2
@Kon1:	mov	[di],bx

@Kon2:	pop	es
	pop	ds
end;


Procedure Vyrad(n:word;w:PMed); assembler;
asm
	push	ds
	push	es
        cld
	les	di,w
	mov	ax,es
        mov	ds,ax

	mov	cx,(TMed ptr es:[di]).size
	jcxz	@Kon1

        mov	dx,di
        add	di,4
	mov	ax,word ptr n
	repne scasw
	jnz	@Kon1
	mov	si,di
	sub	di,2
	rep movsw

        mov	di,dx
	dec	(TMed ptr es:[di]).size
@Kon1:	pop	es
	pop	ds
end;


procedure ZaradBlk(n,w:PMed); assembler;
var p:pointer;
    c:word;
asm
	push	ds
	push	es

	les	di,n
	mov	ax,es             {n<>NIL}
	or	ax,di
	jz	@Kon2
        mov	si,di
	add	si,4
	mov	cx,(TMed ptr es:[di]).size
	or	cx,cx
	jz	@Kon2
	mov	c,cx
	dec	cx
	shl	cx,1
	add	si,cx
	mov	Word ptr p+2,es
	mov	Word ptr p,si

	les	di,w
	mov	ax,es
	or	ax,di			{w<>NIL}
	jz	@Kon2

        mov	si,di
        add	si,4
	mov	ax,es
	mov	ds,ax
	mov	cx,(TMed ptr es:[di]).size


	mov	ax,cx
	add	ax,c               {Vejdu se do w ?}
	cmp	(TMed ptr es:[di]).maxsz,ax
	jc	@Kon2

	mov	ax,cx
	shl	ax,1
	add	si,ax
	sub	si,2
	mov	di,si
	mov	ax,c
	shl	ax,1
	add	di,ax

	std
@Loop3:	push	es
	push	di
	les	di,p
	mov	ax,es:[di]	{Cteni zarazovaneho prvku}
	sub	di,2
	mov	Word ptr p,di
	pop	di
	pop	es

	or	cx,cx
	jmp	@Start1
@Loop1:	dec	cx
@Start1:jz	@Kon1
	cmp	ax,[si]
	movsw
	jc	@Loop1
	add	si,2
	add	di,2
@Kon1:	mov	[di],ax
	sub	di,2
	dec	c
	jnz	@Loop3

	les	di,n                   {Uprava nove delky}
	mov	cx,(TMed ptr es:[di]).size
	les	di,w
	add	cx,(TMed ptr es:[di]).size
	mov	(TMed ptr es:[di]).size,cx

@Kon2:	pop	es
	pop	ds
end;


procedure VyradBlk(n,w:PMed); assembler;
var p:pointer;
    c:word;
asm
	push	ds
	push	es

	les	di,n
	mov	ax,es      {n<>NIL}
	or	ax,di
	jz	@Kon2

	mov	si,di
	add	si,TMed.data
	mov	cx,(TMed ptr es:[di]).size
	or	cx,cx
	jz	@Kon2
	mov	c,cx
	mov	Word ptr p+2,es
	mov	Word ptr p,si

	les	di,w
	mov	ax,es
	or	ax,di		{w<>NIL}
	jz	@Kon2

	mov	bx,es
	mov	si,di
	add	si,TMed.data
	mov	ax,es
	mov	ds,ax
	mov	es,bx
	mov	cx,(TMed ptr es:[di]).size
	mov	es,ax
	mov	ax,cx
	mov	di,si

	push	es
	push	di
	les	di,p
	mov	ax,es:[di]		{Cteni zarazovaneho prvku}
	add	di,2
	mov	Word ptr p,di
	pop	di
	pop	es

	cld
	or	cx,cx
	jz	@Kon1
@Loop1:	cmp	[si],ax
	movsw
	jc	@Loop3
	jnz	@Loop4
	sub	di,2
@Loop4:	push	es
	push	di
	les	di,p
	mov	ax,es:[di]	{Cteni zarazovaneho prvku}
	add	di,2
	mov	Word ptr p,di
	pop	di
	pop	es
	dec	c
	jz	@Kon1
@Loop3:	dec	cx
	jnz	@Loop1
@Kon1:	rep movsw

	sub	si,di
	shr	si,1
	les	di,w
	mov	cx,(TMed ptr es:[di]).size
	sub	cx,si
	mov	(TMed ptr es:[di]).size,cx

@Kon2:	pop	es
	pop	ds
end;


Procedure Median(var Obr1,Obr2:Picture;n:Byte;AlineProc:PAbstractLineProc);
var i,j:Integer;
    x,x1,x2,y,y1,y2:Integer;
    Medi,Lmed:Pmed;
    q:Word;
    Clr:Byte;
    Color:Byte;
Label 10;
begin
Obr2.Erase;
if (n=0) or (Obr1.Data=nil) then exit;
Obr2.Create(Obr1.x,Obr1.y,Obr1.Planes);
if not(Obr2.Valid) then exit;
if AlineProc<>nil then
	AlineProc^.InitPassing(Obr1.x,'Filtering by MEDIAN');

q:=n*n;
Getmem(Medi,2*q+4);
Medi^.MaxSz:=q;
Getmem(Lmed,2*n+4);
Lmed^.MaxSz:=n;
q:=q div 2;
x1:=n div 2;
y1:=n div 2;

color:=0;
if(Obr1.typ='C') and (Obr1.planes=24) then
  begin
  color:=2;
  Obr2.typ:='C';
  if AlineProc<>nil then AlineProc^.pases := AlineProc^.pases*3;
  end;

clr:=0;
while clr<=8*color do
  begin
  for i:=0 to Obr1.x-1 do		{hlavni filtracni smycka}
    begin
    Medi^.Size:=0;
    for x:=i-x1 to i-x1+n-1 do
      if Color<1 then
	begin
	for y:=-y1-1 to -y1+n-2 do
	  Zarad(Pixel(Obr1,x,y),Medi);
	end
      else
	begin
	for y:=-y1-1 to -y1+n-2 do
	  Zarad((Pixel(Obr1,x,y) shr clr) and $FF,Medi);
	end;

    if n>5 then for j:=0 to Obr1.y-1 do
	  begin
	  y:=j-y1-1;
	  Lmed^.Size:=0;

	  if Color<1 then
	    for x:=i-x1 to i-x1+n-1 do Zarad(Pixel(Obr1,x,y),Lmed)
	  else
	    for x:=i-x1 to i-x1+n-1 do Zarad((Pixel(Obr1,x,y) shr clr) and $FF,Lmed);

	  VyradBlk(Lmed,Medi);
	  inc(y,n);
	  Lmed^.Size:=0;
	  if Color<1 then
	    for x:=i-x1 to i-x1+n-1 do Zarad(Pixel(Obr1,x,y),Lmed)
	  else
	    for x:=i-x1 to i-x1+n-1 do Zarad((Pixel(Obr1,x,y) shr clr) and $FF,Lmed);

	  ZaradBlk(Lmed,Medi);

	  if Color<1 then
	    SetPixel(Obr2,i,j,Medi^.data[q])	{ulozeni dat}
	  else
	    SetPixel(Obr2,i,j,Pixel(Obr2,i,j) or (longint(Medi^.data[q]) shl Clr));	{ulozeni dat}
	  end
      else for j:=0 to Obr1.y-1 do
	  begin
	  y:=j-y1-1;

	  if Color<1 then
	    for x:=i-x1 to i-x1+n-1 do Vyrad(Pixel(Obr1,x,y),Medi)
	  else
	    for x:=i-x1 to i-x1+n-1 do Vyrad((Pixel(Obr1,x,y) shr clr) and $FF,Medi);

	  inc(y,n);

	  if Color<1 then
	    begin
	    for x:=i-x1 to i-x1+n-1 do Zarad(Pixel(Obr1,x,y),Medi);
	    SetPixel(Obr2,i,j,Medi^.data[q]);	{ulozeni dat}
	    end
	  else
	    begin
	    for x:=i-x1 to i-x1+n-1 do Zarad((Pixel(Obr1,x,y) shr clr) and $FF,Medi);
	    SetPixel(Obr2,i,j,(Pixel(Obr2,i,j) or (longint(Medi^.data[q]) shl Clr)));	{ulozeni dat}
	    end
	  end;
    if AlineProc<>nil then AlineProc^.NextLine;
    end;

  inc(clr,8);
  end;

Freemem(Lmed,2*n+4);
FreeMem(Medi,2*n*n+4);
end;


Procedure Crop(var Obr1:AbstractPicture;var Obr2:Picture;x0,y0,x1,y1:word;AlineProc:PAbstractLineProc);
var x,y:Word;
    ukRadekW:PradekW;
    ukRadekW2:^Word;
    avalue:Word;
Label EndY0,EndY1,Konec;
begin
Obr2.Erase;
if not(Obr1.Valid) then exit;


Getmem(ukRadekW,2*Obr1.x);

if y1=0 then		{automaticky vyber ctverce}
  begin
  PradekW(ukRadekW2):=ukRadekW;
  Obr1.FormR(0,ukradekW);
  avalue:=ukradekW2^;
  y0:=0;
  y1:=obr1.y-1;
  while y0<=y1 do
     begin
     for x:=0 to obr1.x-1 do
        begin
        if (ukradekW2^<>Avalue) then goto EndY0;
        inc(ukradekW2);
        end;
     inc(y0);
     PradekW(ukRadekW2):=ukRadekW;
     Obr1.FormR(y0,ukradekW);
     end;
EndY0:
  while y0<=y1 do
     begin
     Obr1.FormR(y1,ukradekW);
     PradekW(ukRadekW2):=ukRadekW;
     for x:=0 to obr1.x-1 do
        begin
        if (ukradekW2^<>Avalue) then goto EndY1;
        inc(ukradekW2);
        end;
     dec(y1);
     end;
EndY1:
  end;
if y0>y1 then goto Konec;
if x1=0 then		{automaticky vyber ctverce}
  begin
  x0:=obr1.x-1;
  x1:=0;
  Obr1.FormR(y1,ukradekW);
  avalue:=ukradekW^[0];
  for y:=y0 to y1 do
        begin
        Obr1.FormR(y,ukradekW);
        PradekW(ukRadekW2):=ukRadekW;
        for x:=0 to x0 do
        	begin
                if (ukradekW2^<>Avalue) then
			begin
			x0:=x;
			break;
                        end;
                inc(ukradekW2);
                end;

        PradekW(ukRadekW2):=ukRadekW;
        inc(ukRadekW2,Obr1.x-1);
        for x:=Obr1.x-1 downto x1 do
        	begin
                if (ukradekW2^<>Avalue) then
			begin
			x1:=x;
			break;
                        end;
                dec(ukradekW2);
                end;
        end;
  end;
if x0>x1 then goto Konec;

if x0>x1 then begin;x:=x1;x1:=x0;x0:=x;end;
if y0>y1 then begin;y:=y1;y1:=y0;y0:=y;end;
if x1>Obr1.x then x1:=Obr1.x;
if y1>Obr1.y then y1:=Obr1.y;

PradekW(ukRadekW2):=ukRadekW;
inc(ukRadekW2,x0);
Obr2.Create_(x1-x0,y1-y0,Obr1.Planes,@Obr1);

for y:=y0 to y1-1 do
   begin
   Obr1.FormR(y,ukradekW);
   RfrmB(Obr2,y-y0,ukRadekW2);
   if AlineProc<>nil then if AlineProc^.NextLine<0 then
   	begin
	Obr2.Erase;		{zruseni akce}
	goto Konec;
	end;
   end;

Konec:
FreeMem(ukRadekW,2*Obr1.x);
end;


Procedure Brush(var MainObr:Picture;var Stamp:AbstractPicture;Xpos,Ypos:word;AlineProc:PAbstractLineProc);
var x,y:Word;
    ukRadekW:PradekW;
    ukRadekW2:^Word;
    avalue:Word;
Label EndY0,EndY1,Konec;
begin
if not(MainObr.Valid) or not(Stamp.Valid) then exit;


Getmem(ukRadekW,2*max(MainObr.x,Xpos+Stamp.x));
ukradekW2:=pointer(ukRadekW);
inc(ukRadekW2,Xpos);

for y:=Ypos to min(MainObr.y,Ypos+Stamp.y)-1 do
   begin
   MainObr.FormR(y,ukradekW);
   Stamp.FormR(y-Ypos,(ukRadekW2));

   RfrmB(MainObr,y,ukradekW);
   if AlineProc<>nil then if AlineProc^.NextLine<0 then goto Konec;
   end;

Konec:
Freemem(ukRadekW,2*max(MainObr.x,Xpos+Stamp.x));
end;


Procedure Canny(var im_in,im_out:picture;GausN:integer;scale:real;AlineProc:PAbstractLineProc);
var TempP:Picture;
    x,y,i,a,a2:Word;
    mask,mask2,m2,j:Byte;
    box:array[1..5] of array [1..5] of word;
const vyrazeni:set of byte =[$00,				{nema okoli}
			     $01,$02,$04,$08,$10,$20,$40,$80,	{jeden soused}
      			     $03,$06,$0C,$18,$30,$60,$C0,$81,	{dvojice sousedu}
			     $05,$14,$50,$41,			{dvojice s dirou}
      			     $07,$0E,$1C,$38,$70,$E0,$C1,$83,	{trojice}
                             $0D,$34,$D0,$43,			{trojice s dirou}
                             $85,$16,$58,$61,
                             $15,$54,$51,$45,			{trojice se 2 dirama}
      			     $0F,$1E,$3C,$78,$F0,$E1,$C3,$87,	{ctverice}
                             $1D,$74,$D1,$47,			{ctverice s dirou}
			     $8D,$36,$D8,$63,
			     $C5,$17,$5C,$71,
                             $35,$D4,$53,$4D,			{ctverice se 2 dirama}
                             $95,$56,$59,$65,
                             $1F,$3E,$7C,$F8,$F1,$E3,$C7,$8F,	{petice}
                             $3D,$F4,$D3,$4F,			{petice s dirou}
                             $9D,$76,$D9,$67,
			     $CD,$37,$DC,$73,
			     $E5,$97,$5E,$79,
			     $3F,$7E,$FC,$F9,$F3,$E7,$CF,$9F];	{sestice}
	PocetErozi=2;
begin
  MovePicture(im_in,im_out,nil);
  if Scale>0 then
	begin
	GausFunc(im_out,gfCannyFast,GausN,round(scale*$80000),0,nil);
	exit;
        end;

{jinak nova operace s obrazkem - kompletni Gauss}
 if GausN<=1 then GausN:=40;
 scale:=abs(scale);
 if scale=0 then scale:=1;

 TempP.init;


 MovePicture(im_in,im_out,nil);
 GausFunc(im_out,gfCannyFast,GausN,round(scale*$80000),0,nil);
 while GausN>1 do
       begin
       i:=GausN div 6 + 1;
       dec(GausN,i);

{      im_out.view;
       gotoxy(1,1);write('N=',GausN);
       readkey;{}

       MovePicture(im_in,TempP,nil);
       GausFunc(TempP,gfCannyFast,GausN,round(scale*$80000),0,nil);


{       for y:=0 to im_in.Y-1 do 		asi bude box
           for x:=0 to im_in.X-1 do
           	begin
                end;}

       for y:=0 to im_in.Y-1 do
           begin

           for x:=0 to im_in.X-1 do
             begin
             a:=pixel(im_out,x,y);
             a2:=pixel(tempP,x,y);

	     mask:=$FF;mask2:=$0;
             m2:=0;
             if pixel(im_out,x+1,y  )<>0 then begin;mask2:=Mask2 or  1;inc(m2);end;
             if pixel(im_out,x+1,y-1)<>0 then begin;mask2:=Mask2 or  2;inc(m2);end;
             if pixel(im_out,x  ,y-1)<>0 then begin;mask2:=Mask2 or  4;inc(m2);end;
             if pixel(im_out,x-1,y-1)<>0 then begin;mask2:=Mask2 or  8;inc(m2);end;
             if pixel(im_out,x-1,y  )<>0 then begin;mask2:=Mask2 or 16;inc(m2);end;
             if pixel(im_out,x-1,y+1)<>0 then begin;mask2:=Mask2 or 32;inc(m2);end;
             if pixel(im_out,x  ,y+1)<>0 then begin;mask2:=Mask2 or 64;inc(m2);end;
             if pixel(im_out,x+1,y+1)<>0 then begin;mask2:=Mask2 or 128;inc(m2);end;

             if m2=1 then   		{osamocene konce hran}
             	     begin
                     if (GausN<15) then
                     	begin
                        if (GausN<6) then Continue; {nic uz neporoste}
                        if (a=0)and(a2>0)then {pro male GausN potrebuji >=2 sousedy}
                        	begin
                           	if Mask2 and $55 <>0 then continue; {expanduj pouze do rohu}

		                j:=0;
                                if pixel(tempP,x+1,y  )<>0 then inc(j);
		                if pixel(tempP,x+1,y-1)<>0 then inc(j);
             	                if pixel(tempP,x  ,y-1)<>0 then inc(j);
		                if pixel(tempP,x-1,y-1)<>0 then inc(j);
             	                If pixel(tempP,x-1,y  )<>0 then inc(j);
		                if pixel(tempP,x-1,y+1)<>0 then inc(j);
             	                if pixel(tempP,x  ,y+1)<>0 then inc(j);
             	                if pixel(tempP,x+1,y+1)<>0 then inc(j);
                                if j<2 then Continue; {jinak zustanou bez upravy}
                                end;
                        end;

                     if a2>a then
                     	    begin
			    SetPixel(im_out,x,y,a2);	{prodluz konec primky}
                            Continue;
                            end
                     end;		{jinak je vyradi nasledujici operace}


             if a2=0 then
             	begin
                if (m2>=3)and(a=0) then		{korekce uzlu}
                   begin			{male kolecko - vzdy vypln jeho stred}
                   if (Mask2 and $55 = $55) or	{Uzel S=1}
		       (((((Mask2 and $D6=$D6)and(pixel(im_out,x+2,y )<>0)) or {Uzel S=2}
                         (((Mask2 and $5B=$5B)and(pixel(im_out,x ,y+2)<>0)))) or
                        ((((Mask2 and $6D=$6D)and(pixel(im_out,x-2,y )<>0)) or
                         (((Mask2 and $B5=$B5)and(pixel(im_out,x ,y-2)<>0)))))))
                        	then
                                begin
                                if a<a2 then a:=a2;
                                if a=0 then a:=Pixel(im_out,x+1,y);
                                if a=0 then a:=1;
                                SetPixel(im_out,x,y,a);
                                Continue;
                                end;
                   end;

                if (mask2 in vyrazeni)	{vyjimani bodu}
		                  then
                                  begin
				  SetPixel(im_out,x,y,0);
                                  continue;
                                  end;

                if a>1 then		{drzeny bod- sniz duveru}
                	begin
                        dec(a);
                        SetPixel(im_out,x,y,a);
                        end;

                end;


             if (a2<>0)and(m2>1) then
                begin			{narustani hran, nebo}
                i:=a2;			{totozna hrana = zvys pouze duveru}
                if a>i then i:=a;
                SetPixel(im_out,x,y,i);

{		PutPixel(x,y,Yellow);{}
                Continue;
                end;


	     end;

      if AlineProc<>nil then AlineProc^.NextLine;
      end;

{        write(i,' ',GausN);}
   end;


 while GausN>-PocetErozi do  {pri <=0 pruchodu se pouze docistuje - zaverecne eroze}
 	begin
        dec(GausN);
        TempP.create(im_in.x,im_in.y,im_in.planes); {je na pocatku vynulovan}

	for y:=0 to im_in.Y-1 do
           begin
           for x:=0 to im_in.X-1 do
             begin
             a:=pixel(im_out,x,y);
             if (a=0)and(GausN<0) then Continue;
             a2:=pixel(tempP,x,y);
             if a2>0 then Continue;

	     mask:=$FF;mask2:=$0;
             m2:=0;
             if pixel(im_out,x+1,y  )<>0 then mask2:=Mask2 or  1;
             if pixel(im_out,x+1,y-1)<>0 then mask2:=Mask2 or  2;
             if pixel(im_out,x  ,y-1)<>0 then mask2:=Mask2 or  4;
             if pixel(im_out,x-1,y-1)<>0 then mask2:=Mask2 or  8;
             if pixel(im_out,x-1,y  )<>0 then mask2:=Mask2 or 16;
             if pixel(im_out,x-1,y+1)<>0 then mask2:=Mask2 or 32;
             if pixel(im_out,x  ,y+1)<>0 then mask2:=Mask2 or 64;
             if pixel(im_out,x+1,y+1)<>0 then mask2:=Mask2 or 128;

             if a=0 then
	     	begin
		if Mask2 and $55 = $55{male kolecko - vzdy vypln jeho stred}
                        	then
                                begin
                                a:=Pixel(im_out,x+1,y);
                                SetPixel(im_out,x,y,a);
                                end;
                 Continue;
                 end;

             if mask2 in vyrazeni	{vyjimani bodu}
		             then
                             begin
                             SetPixel(TempP,x+1,y,1);  {zaverecne erozni pruchody}
                             SetPixel(TempP,x-1,y+1,1);
                             SetPixel(TempP,x,  y+1,1);
                             SetPixel(TempP,x+1,y+1,1);

			     SetPixel(im_out,x,y,0);
                             end;
             end;
           end;
        end;


 TempP.Done;
end;


Procedure Gauss(var Obr1,Obr2:picture;n:Byte;AlineProc:PAbstractLineProc);
begin
  MovePicture(Obr1,Obr2,nil);
  GausFunc(Obr2,gfGaus,n,0,0,nil);
end;


Procedure GaussDif(var Obr1,Obr2:picture;n:Byte;typ:char;AlineProc:PAbstractLineProc);
var typdif:Byte;
begin
  case UpCase(typ) of 'X':typdif:=gfGausDiffX;
  		      'Y':typdif:=gfGausDiffY;
                      'L':typdif:=gfGausLap;
	      else typdif:=gfGausDiff;
        end;
  MovePicture(Obr1,Obr2,nil);
  GausFunc(Obr2,gfGausDiff,n,0,0,nil);
end;


{-------------------Detektor hran + Gausian--------------------------}

{procedure tmp;{}

type PLine=^TlineG;
     TlineG=array [0..$1FFF] of longint;


type
  PPtrArr=^TPtrArr;
  TPtrArr=array [0..$1FFF] of pointer;

  PLongBox=^TLongBox;
  TLongBox=object
    Data:PPtrArr;
    SizeX,SizeY:word;
    constructor Init(ASizeX,ASizeY:word);
    destructor  Done;virtual;
    procedure   InsLine(PL:PLine);
    procedure   RollLine;
  end;


type
  MyReal=real; {single;}
  PRealLine=^TRealLine;
  TRealLIne=array [0..$1FFF] of MyReal;
  PReal3Lines=^TReal3Lines;
  TReal3Lines=array[0..2]of PRealLine;


{$L pigaus.obj}

procedure  GausHorN(Line:PLine;sizex,times:word);far;external;
procedure  GausVer1(Line,Line1,Line2,Line3:PLine;sizex:word);far;external;
procedure  DiffHorN(Line:PLine;sizex,times:word);far;external;
procedure  DiffHor1(Line,Line1:PLine;sizex:word);far;external;
procedure  DiffVer1(Line,Line1,Line2,Line3:PLine;sizex:word);far;external;
procedure  DiffHor2(Line,Line1:PLine;sizex:word);far;external;
procedure  DiffVer2(Line,Line1,Line2,Line3:PLine;sizex:word);far;external;
procedure  AbsHor(Line,Line1:PLine;sizex:word);far;external;
procedure  AbsCopy(Line,Line1,Line2:PLine;sizex:word);far;external;
function   EdgeAsm(L:pointer;ux,uy:longint;x:integer):boolean;far;external;
Procedure  EdgeLineAsm(L:pline;BG:pointer;LUX,LUY:pline;sizex:word);far;external;
function   AbsVect(A,B:longint):longint;far;external;
procedure  AddHor(Line,Line1:PLine;sizex:word);far;external;


{===============================================================}
constructor TLongBox.Init(ASizeX,ASizeY:word);
var I:integer;
begin
  SizeY:=ASizeY;
  SizeX:=ASizeX;
  GetMem(Data,ASizeY*4);
  for I:=0 to ASizeY-1 do
  begin
    GetMem(Data^[I],ASizeX*4);
    FillChar(Data^[I]^,ASizeX*4,0);
  end;
end;

destructor  TLongBox.Done;
var I:integer;
begin
  if Data=nil then exit;
  for I:=0 to SizeY-1 do if Data^[I]<>nil then
  begin
    FreeMem(Data^[I],SizeX*4);
    Data^[I]:=nil;
  end;
  FreeMem(Data,SizeY*4);
  Data:=nil;
end;

procedure TLongBox.InsLine(PL:PLine);
begin
  if Data^[0]<>nil then FreeMem(Data^[0],SizeX*4);
  Move(Data^[1],Data^,(SizeY-1)*4);
  Data^[SizeY-1]:=PL;
end;

procedure TLongBox.RollLine;
var PL:PLine;
begin
  PL:=Data^[0];
  Move(Data^[1],Data^,(SizeY-1)*4);
  Data^[SizeY-1]:=PL;
end;
{===============================================================}

procedure ReadLine1(var obr:Picture;Y:integer;PL:PLine);
var SizeX:word;
begin
  if PL=nil then exit;
  if Y>=obr.y then begin
    exit;
  end;
  FormR(obr,Y,PL);
  SizeX:=obr.x;
  asm
	push	ds
	std
	lds	si,[PL]
	les	di,[PL]
	mov	ax,[SizeX]
	shl	ax,1
	add     si,ax
	sub	si,2
	shl	ax,1
	add     di,ax
	sub	di,2
	mov	cx,[SizeX]
@1:     lodsw
	stosw
	xor	ax,ax
	stosw
	loop    @1
	cld
	pop	ds
  end;
end;


Procedure WriteLine(var obr:Picture;Y:integer;PL:PLine;Mult,Offs:longint);
var SizeX:word;
    MaxValue:word;
    K:longint;
begin
  SizeX:=obr.x;
  if Y>=obr.y then exit;
  MaxValue:=longint(1) shl obr.planes - 1;

  asm
	push	ds
	cld
	db 66h;	mov	bx,word ptr[Mult]
	lds	si,[PL]
	les	di,[PL]
	mov	cx,[SizeX]
@1:     db 66h;	lodsw
db 66h;	add	ax,word ptr [Offs]
db 66h;	mul	bx
	mov	ax,MaxValue		{doslo k pretoku ?}
        cmp	ax,dx
        jc	@2
	mov	ax,dx
@2:	stosw
	loop    @1
	pop	ds
  end;
  RfrmB(obr,Y,PL);
end;

(*
Function Edge(BoxG:PReal3Lines;ux,uy:MyReal;j:integer):Boolean;
var uz,ut,gx,gy:MyReal;
begin
 ut:= ux + uy;
 uz:= ux - uy;
 gx:= abs(ux * BoxG^[1]^[j]);
 gy:= abs(uy * BoxG^[1]^[j]);

 edge:=True;
 if (ux*uy > 0) then   {sign(GausDiffX)=sign(GausDiffX)}
     if(abs(ux)<abs(uy)) then {hrana ve smeru X}
       begin
       if (gy<abs(ux*BoxG^[2]^[j+1] - uz*BoxG^[1]^[j+1])) or
		(gy<=abs(ux*BoxG^[0]^[j-1] - uz*BoxG^[1]^[j-1])) then exit
       end
      else
      begin {hrana ve smeru Y}
      if (gx<abs(uy*BoxG^[2]^[j+1] + uz*BoxG^[2]^[j])) or
		(gx<=abs(uy*BoxG^[0]^[j-1] + uz*BoxG^[0]^[j])) then exit;
      end
   else  {sign(GausDiffX)<>sign(GausDiffX)}
    if (abs(ux)<abs(uy)) then  {hrana ve smeru X}
      begin
      if (gy<abs(ux*BoxG^[2]^[j-1] - ut*BoxG^[1]^[j-1])) or
		(gy<=abs(ux*BoxG^[0]^[j+1] - ut*BoxG^[1]^[j+1])) then exit;
      end
     else {hrana ve smeru Y}
      begin
      if (gx<abs(uy*BoxG^[2]^[j-1] - ut*BoxG^[2]^[j])) or
		(gx<=abs(uy*BoxG^[0]^[j+1] - ut*BoxG^[0]^[j])) then exit;
      end;

  edge:=False;
end; *)


procedure GausFunc(var obr:Picture;FuncC,GausN:byte;Mult,Offs:longint;AlineProc:PAbstractLineProc);
var
  LB1,LB2:TLongBox;
  I,J,K,YI,YO,SizeY,SizeX:integer;
  PL,PL1,PL2,PL3:PLine;
  DiffN:byte;
  R3L:TReal3Lines;
  PRL:PRealLine;
  R1,R2,CannyScale:MyReal;
 procedure GausDiffY;
 begin
   I:=SizeY-GausN-1;
   PL :=LB2.Data^[I];
   PL2:=LB1.Data^[I-1];
   LB1.Data^[I-1]:=PL;
   LB2.Data^[I]:=PL2;
   DiffVer1(PL,LB2.Data^[I-1],PL2,LB1.Data^[I],SizeX);
 end;
begin
  DiffN:=0;
  case FuncC of
    gfGaus:;
    gfGausDiffX:DiffN:=1;
    gfGausDiffY:DiffN:=1;
    gfGausDiff :DiffN:=1;
    gfCanny    :DiffN:=1;
    gfCannyFast:DiffN:=1;
    gfGausLap  :DiffN:=1;
  end;
  if Mult=0 then Mult:=$10000;
  SizeX:=obr.x;
  if (FuncC<>gfCanny)and(FuncC<>gfCannyFast) then
    SizeY:=1+GausN+DiffN
  else
  begin
    SizeY:=2+GausN+DiffN;
    for I:=0 to 2 do
    begin
      GetMem(R3L[I],SizeX*sizeof(MyReal));
      FillChar(R3L[I]^,SizeX*sizeof(MyReal),0);
    end;
    CannyScale:=Mult;
    CannyScale:=4/CannyScale;
  end;
  if (SizeX<10)or(obr.y<10) then exit;
  LB1.Init(SizeX,SizeY);
  LB2.Init(SizeX,SizeY);

  YI:=-(SizeY-1);
  YO:=-(2*SizeY-2);
  while YO<obr.Y do
  begin
    LB1.RollLine;
    LB2.RollLine;
    PL:=LB1.Data^[SizeY-1];
    if YI<obr.Y then
      ReadLine1(obr,abs(YI),PL)
    else
      ReadLine1(obr,2*obr.y-YI-2,PL);
    GausHorN(PL,SizeX,GausN);
    inc(YI);
    for I:=SizeY-1 downto SizeY-GausN do
    begin
      PL :=LB2.Data^[I];
      PL2:=LB1.Data^[I-1];
      LB1.Data^[I-1]:=PL;
      LB2.Data^[I]:=PL2;
      GausVer1(PL,LB1.Data^[I],PL2,LB2.Data^[I-1],SizeX);
    end;

    case FuncC of
      gfGaus:if YO>=0 then begin
	WriteLine(obr,YO,LB1.Data^[0],Mult,Offs);
      end;
      gfGausDiffX:if YO>=0 then begin
	PL:=LB1.Data^[0];
	DiffHor1(PL,PL,SizeX);
	WriteLine(obr,YO,PL,Mult,Offs);
      end;
      gfGausDiffY:begin
	GausDiffY;
	PL:=LB1.Data^[0];
	if YO>=0 then WriteLine(obr,YO,PL,Mult,Offs);
      end;
      gfGausDiff :begin
	GausDiffY;
	if YO>=0 then
	begin
	  I:=SizeY-GausN-2;
	  PL :=LB2.Data^[I];
	  PL1:=LB2.Data^[I+1];
	  DiffHor1(PL,PL1,SizeX);
	  PL :=LB1.Data^[I];
	  PL1:=LB2.Data^[I];
	  AbsHor(PL,PL1,SizeX);
	  WriteLine(obr,YO,PL,Mult,Offs);
	end;
      end;
(*      gfCanny:begin
	GausDiffY;
	I:=SizeY-GausN-2;
	DiffHor1(LB2.Data^[I],LB2.Data^[I+1],SizeX);
	PRL:=R3L[0];
	PL :=LB1.Data^[I];
	PL1:=LB2.Data^[I];
	for I:=0 to SizeX-1 do
	begin
	  R1:=PL1^[I];
	  R2:=PL^[I];
	  PRL^[I]:=sqrt(sqr(R1)+sqr(R2));
	end;
	R3L[0]:=R3L[1];R3L[1]:=R3L[2];R3L[2]:=PRL;
	if YO>=0 then
	begin
	  PL1:=LB1.Data^[0];
	  PL2:=LB2.Data^[0];
	  for I:=1 to SizeX-2 do
	  begin
	    if Edge(@R3L,PL1^[I],PL2^[I],I) then
	      setpixel(obr,I,YO,0)
	    else
	    begin
	      R1:=R3L[1]^[I]*CannyScale;
	      if R1>255 then R1:=255;
	      setpixel(obr,I,YO,round(R1));
	    end;
	  end;
	  setpixel(obr,0,YO,0);setpixel(obr,SizeX-1,YO,0);
	end;
      end; *)
      gfCannyFast:begin
	GausDiffY;
	I:=SizeY-GausN-2;
	DiffHor1(LB2.Data^[I],LB2.Data^[I+1],SizeX);
	PRL:=R3L[0];
	PL :=LB1.Data^[1];
	PL1:=LB2.Data^[1];
	AbsCopy(pointer(PRL),PL,PL1,SizeX);

	R3L[0]:=R3L[1];R3L[1]:=R3L[2];R3L[2]:=PRL;
	if YO>=0 then
	begin
	  PL1:=LB1.Data^[0];
	  PL2:=LB2.Data^[0];

	  PL :=PL1;		{ Funkce EdgeLine v Assembleru }
	  EdgeLineAsm(PL,pointer(@R3L),PL1,PL2,SizeX);
	  WriteLine(obr,YO,PL,Mult,Offs);
	end;
      end;
      gfGausLap :begin
	I:=SizeY-GausN-1;
	PL :=LB2.Data^[I];
	PL2:=LB1.Data^[I-1];
	LB1.Data^[I-1]:=PL;
	LB2.Data^[I]:=PL2;
	DiffVer2(PL,LB2.Data^[I-1],PL2,LB1.Data^[I],SizeX);
	if YO>=0 then
	begin
	  I:=SizeY-GausN-2;
	  PL :=LB2.Data^[I];
	  PL1:=LB2.Data^[I+1];
	  DiffHor2(PL,PL1,SizeX);
	  PL :=LB1.Data^[I];
	  PL1:=LB2.Data^[I];
	  AddHor(PL,PL1,SizeX);
	  WriteLine(obr,YO,PL,Mult,Offs);
	end;
      end;
    end;

    if AlineProc<>nil then AlineProc^.NextLine;
    inc(YO);
  end;

  if (FuncC=gfCanny)or(FuncC=gfCannyFast) then
  begin
    for I:=0 to 2 do FreeMem(R3L[I],SizeX*sizeof(MyReal));
  end;
  LB1.Done;
  LB2.Done;
end;


Procedure SetBinPix_norm(x:word;p:pointer); {This procedure set one bit in the bit array}
var b:^byte absolute p;
begin
 inc(b,x shr 3);
 b^:=b^ or ($80 shr(x and $7));{}
{ b^:=b^ or (1 shl (x and $7));{}
end;


Procedure DeClasification(var Obr1:AbstractPicture;var Obr2:Picture;AlineProc:PAbstractLineProc);
var Aloc,SizeLine:Longint;
    i,j:integer;
    NewData1,NewData2:Pointer;
    ukradek1,ukradek2,ukradek:PradekW;
    q:word;
    z:byte;
begin
 Obr2.Erase;
 if not(Obr1.Valid) then exit;
 Obr2.Create(2*Obr1.x+1,2*Obr1.y+1,1);
 if not(Obr2.Valid) then exit;
 if AlineProc<>nil then
	AlineProc^.InitPassing(Obr1.y,'Declasification');

  Aloc:=2*Obr1.x;
  SizeLine:=(Obr2.x+7) div 8;

  getmem(ukRadek1,Aloc);
  getmem(ukRadek2,Aloc);


  fillchar(Obr2.data^[0]^,SizeLine,$FF);
  NewData1:=Obr2.data^[1];
  FormR(Obr1,0,ukRadek2);


  for j:=0 to Obr1.x-2 do
	begin
	if ukRadek2^[j]<>ukRadek2^[j+1] then
			SetBinPix_Norm(2*j+2,NewData1);
	end;

  SetBinPix_norm(0,NewData1);
  SetBinPix_norm(2*Obr1.x,NewData1);

  for i:=1 to Obr1.y-1 do	{hlavni smycka}
    begin
     NewData1:=Obr2.data^[2*i];
     NewData2:=Obr2.data^[2*i+1];

     ukradek:=ukradek1;ukradek1:=ukradek2;ukradek2:=ukradek;
     FormR(Obr1,i,ukRadek2);

     for j:=0 to Obr1.x-2 do
		begin
		q:=ukRadek2^[j];
		z:=0;
		if ukRadek1^[j]<>q   then begin;SetBinPix_norm(2*j+1,NewData1);inc(z);end;
		if ukRadek2^[j+1]<>q then begin;SetBinPix_norm(2*j+2,NewData2);inc(z);end;
		if (z=2)or(ukRadek1^[j+1]<>q) then SetBinPix_norm(2*j+2,NewData1);
		end;
     if ukRadek1^[Obr1.x-1]<>ukRadek2^[Obr1.x-1] then	{posledni bod}
			SetBinPix_norm(2*Obr1.x-1,NewData1);

     SetBinPix_norm(0,NewData1);		{ramecek zleva}
     SetBinPix_norm(0,NewData2);
     SetBinPix_norm(2*Obr1.x,NewData1);	{ramecek zprava}
     SetBinPix_norm(2*Obr1.x,NewData2);

     if AlineProc<>nil then AlineProc^.NextLine;	{Dialog s uzivatelem}
    end;

  fillchar(Obr2.data^[Obr2.y-1]^,SizeLine,$FF);		{posledni pridany radek}

  if ukRadek1<>nil then FreeMem(ukRadek1,Aloc);
  if ukRadek2<>nil then FreeMem(ukRadek2,Aloc);

end;


Procedure MakeNodes(var Obr1:Picture;var Obr2:Picture;AlineProc:PAbstractLineProc);
var tempP:picture;
    i:integer;
    y,DelkaRadku:word;
const StruktureElements:array[0..15] of Telement=
	((Fg:ElCentr+     ElDown+ElRight+ElLeft;Bk:ElLDown),{podelni sousede}
	 (Fg:ElCentr+ElUp+       ElRight+ElLeft;Bk:ElLUp),
	 (Fg:ElCentr+ElUp+ElDown+        ElLeft;Bk:ElLUp),
	 (Fg:ElCentr+ElUp+ElDown+ElRight       ;Bk:ElRDown),
	 (Fg:ElCentr      +ElLup+ElLDown+ElRdown;Bk:0),	{pricni sousede}
	 (Fg:ElCentr+ElRup      +ElLDown+ElRdown;Bk:0),
	 (Fg:ElCentr+ElRup+ElLup        +ElRdown;Bk:0),
	 (Fg:ElCentr+ElRup+ElLup+ElLDown        ;Bk:0),
	 (Fg:ElCentr+ElLUp+ElRight+ElDown;Bk:0),	{kombinovani sousede 1 v rohu}
	 (Fg:ElCentr+ElRUp+ElLeft+ElDown;Bk:0),
	 (Fg:ElCentr+ElRDown+ElUp+ElLeft;Bk:0),
	 (Fg:ElCentr+ElLDown+ElUp+ElRight;Bk:0),
	 (Fg:ElCentr+ElDown+ElRUp+ElLUp;Bk:0),		{kombinovani sousede 1 vedle}
	 (Fg:ElCentr+ElUp+ElRdown+ElLDown;Bk:0),
	 (Fg:ElCentr+ElRight+ElLUp+ElLDown;Bk:0),
	 (Fg:ElCentr+ElLeft+ElRUp+ElRDown;Bk:0));


begin
 TempP.init;
 Obr2.Erase;
 if not(Obr1.Valid) then exit;
 Obr2.Create(Obr1.x,Obr1.y,1);
 if not(Obr2.Valid) then exit;
 if AlineProc<>nil then
	AlineProc^.InitPassing(Obr1.y,'MakingNodes');

 DelkaRadku:=(Obr1.x+7) div 8;

 for i:=0 to 3 do
   begin
   HitOrMiss(Obr1,TempP,StruktureElements[i],nil);
   if not(TempP.valid) then exit;

   for y:=0 to Obr2.y-1 do	{hlavni smycka}
	begin
	OrR(DelkaRadku,Obr2.data^[y],TempP.Data^[y]);
	end;
   end;

 TempP.done;
end;


{<<<<<<<<<<<<<<<<<<<<<<<Vektorove Obrazky>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
const MaxBodu=8000;
      MaxLines=2010;

type Tline=record
	a,b,c:real;
	n:Word;
	end;

   Tbod=record
	x,y:integer;
	end;
   TBodBuf=array[0..MaxBodu] of Tbod;
   PBodBuf=^TbodBuf;
   TLineBuf=array[0..MaxLines] of Tline;
   PLineBuf=^TlineBuf;


Procedure AddVecLine(var v:VectorPicture;BytesInLine:Word);
var p:Pointer;
begin
 p:=v.v;
 inc(v.Lines);
 GetMem(v.v,v.Lines*Sizeof(UkVectorObject));
 v.v^[v.Lines-1]:=nil;
 if p<>nil then
	begin
	Move(p^,v.v^,(v.Lines-1)*Sizeof(UkVectorObject));
	FreeMem(p,(v.Lines-1)*Sizeof(UkVectorObject));
	end;
 GetMem(v.v^[v.Lines-1],BytesInLine);	{New Line Data}
end;


Function ZjistiUhel(dx,dy:real):real;
var zu:real;
begin
if dx=0 then
	begin
	if dy>0 then ZjistiUhel:= pi/2;
        if dy<0 then ZjistiUhel:= pi*3/2;
        exit;
        end;
if dy=0 then
	begin
        if dx>0 then ZjistiUhel:= 0;
        if dx<0 then ZjistiUhel:= pi;
        exit;
        end;
Zu:=dx/dy;
if abs(Zu-1) > 0.1 then Zu:=arctan(abs(dy/dx))
		   else Zu:=pi/4;
if (dx<0)and(dy>0) then zu:=pi-zu;
if (dx<0)and(dy<0) then zu:=pi+zu;
if (dx>0)and(dy<0) then zu:=2*pi-zu;
ZjistiUhel:=Zu;
end;


Function primka(x1,x2:Word;var a,b,c,e2:real;Linea:PBodBuf):real;
var x,y,xx,yy,xy:real;
    n,i:word;
    e:real;
begin
Primka:=0;
x:=0; y:=0; xx:=0; yy:=0; xy:=0;
for i:=x1 to x2 do
	begin
	x:=x+linea^[i].x;
	y:=y+linea^[i].y;
	xx:=xx+longint(linea^[i].x)*linea^[i].x;
	yy:=yy+longint(linea^[i].y)*linea^[i].y;
	xy:=xy+longint(linea^[i].x)*linea^[i].y;
	end;
n:=x2-x1+1;
e:=0;
e2:=0;
if n<=1	then		{1 bod? - zadna primka}
	begin
	a:=0;b:=0;c:=0;
	exit;	
	end;

if (abs(linea^[x1].x-linea^[x2].x)>abs(linea^[x1].y-linea^[x2].y))or(abs(yy-y*y/n)<=1e-6) then
	begin
	a:=(xy-x*y/n)/(xx-x*x/n);
	b:=-1;
	c:=(y-a*x)/n;
	end
   else begin
	a:=-1;
	b:=(xy-x*y/n)/(yy-y*y/n);
	c:=(x-b*y)/n;
	end;
if n<=2 then exit;	{2 body - primka bez odchylky}

for i:=x1 to x2 do		{urceni chyby aproximace}
  begin
  x:=sqr(a*linea^[i].x+b*linea^[i].y+c)/(sqr(a)+sqr(b));
  e:=e+x;
  if x2-i<5 then e2:=e2+ x;
  end;
if (linea^[x1].y=linea^[x2].y)and(linea^[x1].x=linea^[x2].x) then e:=1e+9
 else e:=e/sqrt(abs(longint(linea^[x1].x-linea^[x2].x)*longint(linea^[x1].x-linea^[x2].x)+
	longint(linea^[x1].y-linea^[x2].y)*longint(linea^[x1].y-linea^[x2].y)));
primka:=e;
end;


Function pixel2(var p:picture;x,y:integer):Byte;
begin
pixel2:=0;
if ((x>=p.x)or(y>=p.y))or((x<0)or(y<0)) then exit;
pixel2:=pixel(p,x,y);
end;


Procedure DetekujHranu(var p:picture;xstart,ystart:integer;var Linenum:Word;Linea:PBodBuf;obvod:PlineBuf;Options:PCVOpt);
var x,y,lastx,lasty,ly2:integer;
    a,b,c,e,e2,eps:real;
    cislobodu,CelkoveCisloBodu,LastDir:integer;
    k:integer;
    corrupt,nalezeno,uzavreno:Boolean;
Label 10;
begin
x:=xstart;
y:=ystart;
CelkoveCislobodu:=0;

10:
with options^ do while pixel(p,x,y)>0 do
	begin
	inc(CelkoveCisloBodu);
        if CelkoveCisloBodu>=MaxBodu then Break; {pretekl zasobnik v pameti}
        linea^[CelkoveCisloBodu].x:=x;
	linea^[CelkoveCisloBodu].y:=y;
	ClearPixel(p,x,y);
							   {ctyrokoli}
	if pixel2(p,x+1,y)>=Pl   then begin;inc(x);LastDir:=0;continue;end;
        if pixel2(p,x,y+1)>=Pl   then begin;inc(y);LastDir:=2;continue;end;
        if pixel2(p,x-1,y)>=Pl   then begin;dec(x);LastDir:=4;continue;end;
        if pixel2(p,x,y-1)>=Pl   then begin;dec(y);LastDir:=6;continue;end;
                                                            {osmiokoli}
        if pixel2(p,x+1,y+1)>=Pl then begin;inc(x);inc(y);LastDir:=1;continue;end;
        if pixel2(p,x-1,y+1)>=Pl then begin;dec(x);inc(y);LastDir:=3;continue;end;
        if pixel2(p,x-1,y-1)>=Pl then begin;dec(x);dec(y);LastDir:=5;continue;end;
        if pixel2(p,x+1,y-1)>=Pl then begin;inc(x);dec(y);LastDir:=7;continue;end;
        if Pa<Pl then
         begin                                              {ctyrokoli}
 	 if pixel2(p,x+1,y)>=Pa   then begin;inc(x);LastDir:=0;continue;end;
         if pixel2(p,x,y+1)>=Pa   then begin;inc(y);LastDir:=2;continue;end;
         if pixel2(p,x-1,y)>=Pa   then begin;dec(x);LastDir:=4;continue;end;
         if pixel2(p,x,y-1)>=Pa   then begin;dec(y);LastDir:=6;continue;end;
                                                             {osmiokoli}
         if pixel2(p,x+1,y+1)>=Pa then begin;inc(x);inc(y);LastDir:=1;continue;end;
	 if pixel2(p,x-1,y+1)>=Pa then begin;dec(x);inc(y);LastDir:=3;continue;end;
         if pixel2(p,x-1,y-1)>=Pa then begin;dec(x);dec(y);LastDir:=5;continue;end;
         if pixel2(p,x+1,y-1)>=Pa then begin;inc(x);dec(y);LastDir:=7;continue;end;
         end;
        end;
linea^[CelkoveCisloBodu].x:=x;linea^[CelkoveCisloBodu].y:=y;
uzavreno:=false;
if CelkoveCisloBodu>8 then if (abs(x-xstart)<=2)and(abs(y-ystart)<=2) then
                     	begin
                        inc(CelkoveCisloBodu);
                        linea^[CelkoveCisloBodu].x:=xstart;
			linea^[CelkoveCisloBodu].y:=ystart;
                        uzavreno:=True;
                        end;
                        {spojovani roztrzenych oblasti}
if (not(uzavreno) and (CelkoveCisloBodu<MaxBodu))and(CelkoveCisloBodu>3) then
  with options^ do
	begin
        LineNum:=255;			   {zkouska postupovat druhym smerem}
	x:=Xstart;y:=Ystart;
        if pixel2(p,x+1,y)>=Pa  then LineNum:=0;
        if pixel2(p,x,y+1)>=Pa  then LineNum:=2;
        if pixel2(p,x-1,y)>=Pa  then LineNum:=4;
        if pixel2(p,x,y-1)>=Pa  then LineNum:=6;
                                                            {osmiokoli}
        if pixel2(p,x+1,y+1)>=Pa then LineNum:=1;
        if pixel2(p,x-1,y+1)>=Pa then LineNum:=3;
        if pixel2(p,x-1,y-1)>=Pa then LineNum:=5;
        if pixel2(p,x+1,y-1)>=Pa then LineNum:=7;

        if LineNum<>255 then
        	begin
                for k:=1 to (CelkoveCisloBodu+1) div 2 do
                	begin
                        lastY:=linea^[CelkoveCisloBodu-k+1].y;
                        lastX:=linea^[CelkoveCisloBodu-k+1].x;
                        linea^[CelkoveCisloBodu-k+1]:=linea^[k];
			linea^[k].y:=LastY;
                        linea^[k].x:=LastX;
                        end;
                SetPixel(p,Xstart,Ystart,255); {obnov pocatecni bod}
                Xstart:=linea^[1].x;
                Ystart:=linea^[1].y;
                Dec(CelkoveCisloBodu);
                Goto 10;
                end;

	y:=linea^[CelkoveCisloBodu].y;
        x:=linea^[CelkoveCisloBodu].x;		   {ctyrokoli korekce o 1}
	if LastDir=0 then if pixel2(p,x+2,y)>=Pl then begin;inc(x,2);Goto 10;end;
        if LastDir=2 then if pixel2(p,x,y+2)>=Pl then begin;inc(y,2);Goto 10;end;
        if LastDir=4 then if pixel2(p,x-2,y)>=Pl then begin;dec(x,2);Goto 10;end;
        if LastDir=6 then if pixel2(p,x,y-2)>=Pl then begin;dec(y,2);Goto 10;end;
						   {osmiokoli korekce o 1}
        if LastDir=1 then if pixel2(p,x+2,y+2)>=Pl then begin;inc(x,2);inc(y,2);Goto 10;end;
	if LastDir=3 then if pixel2(p,x-2,y+2)>=Pl then begin;dec(x,2);inc(y,2);Goto 10;end;
        if LastDir=5 then if pixel2(p,x-2,y-2)>=Pl then begin;dec(x,2);dec(y,2);Goto 10;end;
        if LastDir=7 then if pixel2(p,x+2,y-2)>=Pl then begin;inc(x,2);dec(y,2);Goto 10;end;
        end;

nalezeno:=True;
CisloBodu:=0;
LineNum:=1;

while CisloBodu<CelkoveCisloBodu do
  begin
  x:=linea^[CisloBodu].x;y:=linea^[CisloBodu].y;
  k:=CisloBodu+1;		{minimalni delka usecky}
  ly2:=16;
  eps:=Options^.eps; {0.8;}
  obvod^[linenum].c:=0;

  if CelkoveCisloBodu<200 then ly2:=8;
  if (CelkoveCisloBodu<100)and(eps>0.5) then eps:=eps*0.5;
  if CelkoveCisloBodu<20 then ly2:=2;
  if CelkoveCisloBodu>600 then ly2:=32;
  if CelkoveCisloBodu>1000 then ly2:=64;
  if k>=celkoveCisloBodu then k:=CelkoveCisloBodu
     else while(k<CelkoveCisloBodu) do
        begin
        lasty:=k+ly2;
        if lasty>CelkoveCisloBodu then LastY:=CelkoveCisloBodu;
        e:=primka(CisloBodu,lastY,a,b,c,e2,linea);
	if (e>eps)or(e2>16) then ly2:=ly2 div 2
       			 else
			 begin
			 k:=lasty;
                         obvod^[linenum].a:=a;
			 obvod^[linenum].b:=b;
			 obvod^[linenum].c:=c;
			 end;
	if ly2=0 then break;
{$ifdef graph}
	if options^.Tisk then putpixel(linea^[k].x,linea^[k].y,white);
{$endif}
        end;
  if obvod^[linenum].c=0 then
  	begin
        obvod^[linenum].a:=a;
	obvod^[linenum].b:=b;
	obvod^[linenum].c:=c;
        end;

  obvod^[linenum].n:=k;
  inc(lineNum);
{$ifdef graph}
  if options^.Tisk then
  	begin
	if odd(k) then SetColor(magenta)
             	  else SetColor(brown);
	line(x,y,linea^[k].x,linea^[k].y);
        end;
{$endif}
  CisloBodu:=k;
  end;

CisloBodu:=1;		{minimalizace ztraty rohu}
for k:=1 to LineNum-2 do
  begin
  lasty:=obvod^[k].n;
  e:=primka(CisloBodu,lastY,a,b,c,e2,Linea)+primka(lastY,obvod^[k+1].n,a,b,c,e2,Linea);
  e2:=e;
  while (e2<=e)and(LastY-CisloBodu>3) do
  	begin
        e:=e2;
        dec(LastY);
        e2:=primka(lastY,obvod^[k+1].n,a,b,c,e2,Linea);
        e2:=e2+primka(CisloBodu,lastY,a,b,c,e2,Linea); {ztrata obou rohovych usecek}
        if e2<e then
		begin
                obvod^[k].n:=LastY;
                obvod^[k].a:=a;
                obvod^[k].b:=b;
                obvod^[k].c:=c;{}
                end;
        end;
  CisloBodu:=obvod^[k].n;
  end;


if uzavreno and (LineNum>=5) then   {pokus o slouceni 1. a posledni primky}
  begin
  k:=obvod^[1].n;
  if obvod^[lineNum-1].n+k<MaxBodu then
  	begin
        for LastY:=2 to k do linea^[CelkoveCisloBodu+LastY-1]:=linea^[LastY];
        lastY:=CelkoveCisloBodu+k-1;
	if primka(obvod^[Linenum-2].n,LastY,a,b,c,e2,Linea)<0.5 then if e2<20 then
        	begin
                obvod^[1].a:=a;
                obvod^[1].b:=b;
                obvod^[1].c:=c;{}
                CelkoveCisloBodu:=obvod^[Linenum-2].n;
                Xstart:=linea^[CelkoveCisloBodu].x;
                Ystart:=linea^[CelkoveCisloBodu].y;
                dec(Linenum);
                end;
	end;
  end;

corrupt:=False;
if uzavreno then	{prusecik pocatecni a koncove primky}
        begin
        a:=obvod^[lineNum-1].a;b:=obvod^[lineNum-1].b;c:=obvod^[LineNum-1].c;
        if abs(a*obvod^[1].b-b*obvod^[1].a)>1E-11 then
	   e:=(b*obvod^[1].c-c*obvod^[1].b)/(a*obvod^[1].b-b*obvod^[1].a)
           else Corrupt:=true;
        if abs(b*obvod^[1].a-a*obvod^[1].b)>1E-11 then
	   e2:=(a*obvod^[1].c-c*obvod^[1].a)/(b*obvod^[1].a-a*obvod^[1].b)
           else Corrupt:=true;
        if not(corrupt) then if (sqr(e-Xstart)+sqr(e2-Ystart))>36 then
		Corrupt:=True; {6^2 nekorektni chyba extrapolace > 7 bodu}
        if not(Corrupt) then
        	begin
                Xstart:=round(e);
                Ystart:=round(e2);
                linea^[CelkoveCisloBodu].x:=xstart; {!!!prepisuje data!!!}
		linea^[CelkoveCisloBodu].y:=ystart;
                end
        end;
linea^[0].x:=Xstart;linea^[0].y:=Ystart;
obvod^[Linenum-1].n:=CelkoveCisloBodu;

x:=xstart;y:=ystart;		{vypocet pruseciku primek}
corrupt:=false;
if CelkoveCisloBodu<12 then Corrupt:=True;
for k:=1 to LineNum-2 do
  begin
  lastX:=x;LastY:=Y;
  if not corrupt then
	begin
	a:=obvod^[k].a;b:=obvod^[k].b;c:=obvod^[k].c;
        if abs(a*obvod^[k+1].b-b*obvod^[k+1].a)>1E-11 then
           e:=(b*obvod^[k+1].c-c*obvod^[k+1].b)/(a*obvod^[k+1].b-b*obvod^[k+1].a)
           else Corrupt:=true;
        if abs(b*obvod^[k+1].a-a*obvod^[k+1].b)>1E-11 then
	   e2:=(a*obvod^[k+1].c-c*obvod^[k+1].a)/(b*obvod^[k+1].a-a*obvod^[k+1].b)
           else Corrupt:=true;
        if (sqr(e-linea^[obvod^[k].n].x)+sqr(e2-linea^[obvod^[k].n].y))<49 {7^2}
		then	{nekorektni chyba extrapolace > 7 bodu}
		begin
		linea^[obvod^[k].n].x:=round(e);;
                linea^[obvod^[k].n].y:=round(e2);;
                end;
        end;
  end;

end;


Constructor CVOpt.Init(planes:Word);
begin
  planes:=1 shl Planes;
  Pl:=round(0.04*planes);
  if Pl=0 then inc(Pl);
  Pa:=round(0.9 *planes);
  eps:=0.9;
  tisk:=True;
  AutoErase:=True;
end;


Procedure Convert2vector(var obr:picture;var vobr:VectorPicture;Options:PCVOpt;AlineProc:PAbstractLineProc);
var i,j:integer;
    Linea:PbodBuf;
    obvod:PlineBuf;
    k,x,y:integer;
    LineNum:Word;
begin
Vobr.Erase;
Vobr.lines:=0;
if Obr.Data=nil then exit;
Vobr.x:=Obr.x;
Vobr.y:=Obr.y;
Vobr.Planes:=Obr.planes;

if Options=nil then new(Options,Init(Obr.Planes));
LineNum:=0;

Getmem(Linea,(MaxBodu+1)*Sizeof(Tbod));
Getmem(Obvod,MaxLines*Sizeof(Tline));
for i:=1 to obr.x-2 do
  begin
  for j:=1 to obr.y-2 do if pixel(obr,i,j)>=Options^.Pl then
     begin
     DetekujHranu(obr,i,j,linenum,linea,obvod,options);{}
     x:=linea^[0].x;y:=linea^[0].y;
{$ifdef graph}
     if Options^.tisk then setColor(Yellow);
{$endif}

     AddVecLine(Vobr,LineNum*Sizeof(Point)+Sizeof(Word)+Sizeof(Byte));
     Vobr.v^[Vobr.Lines-1]^.points:=Linenum;
     Vobr.v^[Vobr.Lines-1]^.color:=Options^.Pl;
     for k:=0 to LineNum-1 do
     	begin
{$ifdef graph}
        if Options^.tisk and (k>0) then line(x,y,Vobr.v^[Vobr.Lines-1]^.data[k-1].x,Vobr.v^[Vobr.Lines-1]^.data[k-1].y);
{$endif}
	Vobr.v^[Vobr.Lines-1]^.data[k].x:=x;
	Vobr.v^[Vobr.Lines-1]^.data[k].y:=y;
        if k<Linenum-1 then
           begin
           x:=linea^[obvod^[k+1].n].x;
           y:=linea^[obvod^[k+1].n].y;
           end;
        end;
     end;
  if AlineProc<>nil then AlineProc^.NextLine;
  end;

if Options^.AutoErase then dispose(Options);
end;


Procedure Line1(x1,y1,x2,y2,y,maxX:integer;NewData:Pointer);
var dx,dy,p,k1,k2,incr:integer;
    uWord:^RadekW absolute NewData;
    t:real;
begin
dx:=abs(x1-x2);
dy:=abs(y1-y2);
if dx>dy then
  begin
  if(x1>x2) then
  	begin
        p:=x1;x1:=x2;x2:=p;
        p:=y1;y1:=y2;y2:=p;
        end;
  if(y2>y1) then incr:=+1
  	    else incr:=-1;
  p:=2*dy-dx;
  k1:=2*dy;
  k2:=2*(dy-dx);
  if y1=Y then uWord^[x1]:=10;
  while(x1<x2) do
	 begin
         inc(x1);
         if(p<0) then inc(p,k1)
        	 else begin
                      inc(y1,incr);
		      inc(p,k2);
                      if ((incr=1)and(y1>y))or((incr=-1)and(y1<y)) then
		      			break; {usecku nema smysl dale kreslit}
		      end;
         if (y1=Y) then
	 	if (x1<maxX)and(x1>0) then uWord^[x1]:=10;
         end;
  end
  else			{DY>=DX - staci pouze 1 bod pruseciku}
  begin
  if (not((Y-y1)>0)xor((y2-y1)>0)) and (abs(Y-y1)<dy) then
	begin
        if dy<>0 then x1:=x1+longint((Y-y1)*(x2-x1)) div (y2-y1);
	if (x1<maxX)and(x1>=0) then
	   begin
           uWord^[x1]:=10;
           end;
        end;
  end;
end;


Procedure VectorPicture.FormR(i:integer;FData:Pointer);
var j,k,x1,x2,y1,y2:integer;
    t:real;
begin
fillchar(FData^,2*X,0);
for j:=0 to lines-1 do
  if v^[j]<>nil then
    for k:=0 to v^[j]^.points-2 do with v^[j]^ do
	begin
	y1:=data[k].y;
	x1:=data[k].x;
	y2:=data[k+1].y;
	x2:=data[k+1].x;
        line1(x1,y1,x2,y2,i,x,FData);
	end;
end;


{$ifdef graph}
Procedure vectorpicture.View;
var i,b:integer;
    p:Point;
label Konec;
begin
ClearDevice;
for i:=0 to lines-1 do if v^[i]<>nil then
	begin
	if v^[i]^.color<>0 then SetColor(v^[i]^.color);

 {      readkey;
        cleardevice;{}
        p:=v^[i]^.data[0];
        for b:=0 to v^[i]^.points-1 do
          begin
          line(p.x-offsetX,p.y-offsetY,v^[i]^.data[b].x-offsetX,v^[i]^.data[b].y-offsetY);
          p:=v^[i]^.data[b];
          end;

	if AlineProc<>nil then if AlineProc^.NextLine<0 then goto Konec;{Dialog s uzivatelem}
        end;
Konec:
end;
{$endif}


Function VectorPicture.Valid:Boolean;
begin
 Valid:=v<>nil;
end;


Constructor vectorpicture.Init;
var i:word;
begin
 typ:='V';
 lines:=0;
 v:=nil;
 palette:=nil;
end;


Procedure vectorpicture.Erase;
var i:Word;
begin
 ErasePalette(palette);
 if v=nil then exit;
 for i:=0 to lines-1 do FreeMem(v^[i],v^[i]^.points+Sizeof(Word));
 FreeMem(v,Lines*Sizeof(UkVectorObject));
 v:=nil;
 lines:=0;
end;

Destructor vectorpicture.Done;
begin
 Erase;
 if filename<>nil then
	begin
	dispose(filename);
	filename:=nil;
	end;
end;


Procedure LoadVecPictureAsc(var vobr:VectorPicture);
var txt:text;
    i,b:integer;
    c:char;
    BufData:array[0..1000] of point;
    a:string;
    NumOk,color:Word;
    r:Real;
Label 10,20,30;
begin
Vobr.Erase;
assign(txt,vobr.filename^);
reset(txt);
If IoResult<>0 then goto 30;
i:=0;
color:=10;
while not(eof(txt)) do
	begin
	readln(txt,a);
        while (a<>'')and(a[1]<=' ') do a:=copy(a,2,length(a)-1);
        if copy(a,1,3)='END' then break; 	{koncova znacka END}

        readln(txt,a);
        b:=0;
        repeat
          while (a<>'')and(a[1]<=' ') do a:=copy(a,2,length(a)-1);
          val(a,r,NumOk);
          if NumOk>1 then
          	begin
                c:=a[0];
                a[0]:=chr(NumOk-1);
                val(a,r,NumOk);
                a[0]:=c;
                end;
          bufdata[b].x:=round(r);

          if NumOk=0 then
          	begin
		while (a<>'') and (a[1] in ['0'..'9','.','-','+','E']) do a:=copy(a,2,length(a)-1);
                while (a<>'')and(a[1]<=' ') do a:=copy(a,2,length(a)-1);
                val(a,r,NumOk);
                if NumOk>1 then
          		begin
        	        a[0]:=chr(NumOk-1);
                	val(a,r,NumOk);
                        end;
                bufdata[b].y:=round(r);
                if NumOk=0 then inc(b);
                end;

20:       if IOresult<>0 then goto 10;
	  readln(txt,a);
        until ((b>1000)or(copy(a,1,3)='END'))  or((a='')and(eof(txt)));
        if b<>0 then
        	begin
		AddVecLine(Vobr,b*Sizeof(Point)+Sizeof(Word)+Sizeof(byte));
		Move(BufData,vobr.v^[i]^.data,b*Sizeof(Point));
	        vobr.v^[i]^.points:=b;
		vobr.v^[i]^.color:=color;
                inc(i);
                end;
        end;
10:close(txt);
30:
end;


Procedure LoadVecPictureHPG(var vobr:VectorPicture);
var txt:text;
    pen:integer;
    i:Word;
    s:string[4];
    c:char;

    UnknownCommands:Word;
    BufData:array[0..1000] of point;
begin
assign(txt,vobr.FileName^);
reset(txt);
UnknownCommands:=0;
pen:=0;
BufData[0].x:=0;
BufData[0].y:=0;

while not(eof(txt)) do
  begin
  s:='';
  c:=#0;
  repeat
    if c<>#0 then s:=s+UpCase(c);
    if length(s)>3 then s:=copy(s,2,length(s)-1);
    read(txt,c);
  until ((c in [#0..' ','.',':',',',';','0'..'9']) and (s<>''))or(eof(txt));

  if s='PU' then	{premisteni pera}
	begin
	while c<>';' do
	  begin
	  BufData[0].x:=ReadInt(txt,c) div 10;
	  BufData[0].y:=ReadInt(txt,c) div 10;
	  if eof(txt) then Break;
	  end;
	continue;
	end;
  if s='PD' then	{kresleni - pero dole}
	begin
	i:=1;
	while c<>';' do
	     begin
	     BufData[i].x:=ReadInt(txt,c) div 10;
	     BufData[i].y:=ReadInt(txt,c) div 10;
	     if i<999 then inc(i);
	     if eof(txt) then Break;
	     end;

	AddVecLine(Vobr,i*Sizeof(Point)+Sizeof(Word)+Sizeof(byte));
	Move(BufData,vobr.v^[vobr.Lines-1]^.data,i*Sizeof(Point));
	vobr.v^[vobr.Lines-1]^.points:=i;
	vobr.v^[vobr.Lines-1]^.color:=pen;

	dec(i);
	BufData[0].x:=BufData[i].x;
	BufData[0].y:=BufData[i].y;

	continue;
	end;

  if s='SP' then	{vyber pera}
	begin
	pen:=ReadInt(txt,c);
	if pen = 1 then pen:=0;
	continue;
	end;
  if s='IN' then	{inicializace}
	begin
	pen:=10;
	BufData[0].x:=0;
	BufData[0].y:=0;
	continue;
	end;
  if s='LT' then	{typ cary}
	begin
	if c=';' then continue;
	ReadInt(txt,c);
	continue;
	end;
  if s='DF' then	{default hodnoty}
	begin
	continue;
	end;

  inc(UnknownCommands);
  end;

close(txt);
end;


Procedure LoadVecPictureTXT(var vobr:VectorPicture);
var txt:text;
    i,b:integer;
    c:char;
    BufData:array[0..1000] of point;
    color:Byte;
Label 10,20,30;
begin
Vobr.Erase;
assign(txt,vobr.filename^);
reset(txt);
If IoResult<>0 then goto 30;
i:=0;
while not(eof(txt)) do
	begin
        b:=0;
	color:=10;	{transparentni barva}
	  repeat
	  c:=#0;
	  bufdata[b].x:=readInt(txt,c);
	  if c=':' then
	  	begin;
		color:=bufdata[b].x;
                if b=0 then c:=' ';
		continue;
		end;
          if c<>',' then goto 20;
	  bufdata[b].y:=readInt(txt,c);
          inc(b);
20:       if IOresult<>0 then goto 10;
          until (b>1000) or (((c=#10)or(c=#13))or(c<>' '));
          if b<>0 then
        	begin
		AddVecLine(Vobr,b*Sizeof(Point)+Sizeof(Word)+Sizeof(byte));
		Move(BufData,vobr.v^[i]^.data,b*Sizeof(Point));
	        vobr.v^[i]^.points:=b;
                vobr.v^[i]^.color:=color;
                inc(i);
                end;
        end;
10:close(txt);
30:
end;


Procedure vectorpicture.Load(ext:ExtStr;AlineProc:PAbstractLineProc);
begin
 if ext='ASC' then LoadVecPictureASC(self);
 if ext='HPG' then LoadVecPictureHPG(self);
 if ext='TXT' then LoadVecPictureTXT(self);;
 x:=1000;
 y:=1000;
end;


Function SaveVecPictureHPG(var vobr:VectorPicture):Boolean;
var txt:text;
    i,b:integer;
    pen:integer;
begin
SaveVecPictureHPG:=False;
assign(txt,vobr.FileName^);
rewrite(txt);
if IOResult<>0 then exit;
pen:=0;
write(txt,'.@;3:.I:IN;DF;PU0,0;LT;');
for i:=0 to vobr.Lines-1 do if vobr.v^[i]<>nil then
	begin
	if Vobr.v^[i]^.color<>pen then
		begin
		pen:=Vobr.v^[i]^.color;
		write(txt,'SP',pen,';');
		end;
	for b:=0 to Vobr.v^[i]^.points-1 do
	  begin
	  if b=0 then
		 begin
		 write(txt,'PU',Vobr.v^[i]^.data[b].x,',',Vobr.v^[i]^.data[b].y,';PD');
		 end
		 else write(txt,Vobr.v^[i]^.data[b].x,',',Vobr.v^[i]^.data[b].y);
	  if b<>Vobr.v^[i]^.points-1 then write(txt,',')
				     else write(txt,';');
	  end;
	end;
write(txt,'SP0;PU0,0;');
close(txt);
if IOresult=0 then SaveVecPictureHPG:=True;
end;


Function SaveVecPictureTXT(var vobr:VectorPicture):Boolean;
var txt:text;
    i,b:integer;
begin
SaveVecPictureTXT:=False;
assign(txt,vobr.filename^);
rewrite(txt);
if IOResult<>0 then exit;
for i:=0 to vobr.Lines-1 do if vobr.v^[i]<>nil then
	begin
	for b:=0 to Vobr.v^[i]^.points-1 do
	  begin
	  write(txt,Vobr.v^[i]^.data[b].x, ',',Vobr.v^[i]^.data[b].y,' ');
	  if b=0 then write(txt,' ');
	  end;
	writeln(txt);
	end;
close(txt);
if IOresult=0 then SaveVecPictureTXT:=True;
end;


Function vectorpicture.Save(AlineProc:PAbstractLineProc):Boolean;
var ext:string[4];
    i:Byte;
begin
 ext:=copy(filename^,length(filename^)-2,3);
 for i:=1 to 4 do ext[i]:=upcase(ext[i]);
 if ext='HPG' then Save:=SaveVecPictureHPG(self);
 if ext='TXT' then Save:=SaveVecPictureTXT(self);
end;


{------Error Handling Procedures------}
const ErrArray:array[0..15] of integer = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
      ErrorPos:Byte=0;
Function PeepError:integer;
begin
 PeepError:=ErrArray[ErrorPos];
end;


Function ReadError:integer;
begin
 ReadError:=ErrArray[ErrorPos];
 ErrArray[ErrorPos]:=0;
 if ErrorPos>0 then dec(ErrorPos);
end;


Procedure WriteError(Error:integer);
begin
 if ErrorPos<15 then inc(ErrorPos);
 ErrArray[ErrorPos]:=Error;
end;


Function GetErrorString(Error:integer):String;
begin
GetErrorString:='Unknown';
case Error of
	  0:GetErrorString:='Ok';
  ErrFormat:GetErrorString:='Unsupported image format';
  ErrRdDisk:GetErrorString:='Cannot read File';
  ErrWRDisk:GetErrorString:='Cannot write to File';
     ErrMem:GetErrorString:='Not Enough Memory';
     ErrBrk:GetErrorString:='User break';
    ErrData:GetErrorString:='Incorrect data';
 ErrVariant:GetErrorString:='Unsupported variant of image data';
    end;
end;


end.